{-# 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, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tuple (swap)
import qualified Data.Vector.Algorithms.Intro as I
import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed as VU
import Data.Word (Word32)
import Debug.Trace (trace)
import Graph.CommonGraph
  ( CGraph,
    CGraphL,
    Channel,
    Column,
    EdgeClass (channelNrIn, channelNrOut, dummyEdge, standard),
    EdgeType (NormalEdge),
    GraphMoveX,
    LayerFeatures (LayerFeatures),
    NodeClass (connectionNode, dummyNode, isConnNode, isDummy, isMainArg, isSubLabel, subLabels),
    UINode,
    childrenNoVertical,
    childrenSeparating,
    childrenVertical,
    isFunction,
    myFromJust,
    myhead,
    parentsNoVertical,
    parentsVertical,
    rmdups,
    verticallyConnectedNodes,
    vhead,
  )
import qualified Graph.CommonGraph as Common
import Graph.IntMap (Graph (..), nodes)
import qualified Graph.IntMap as Graph

-- Also returns a map with Columns to allow navigation with arrows
layeredGraphAndCols ::
  (NodeClass n, Show n, EdgeClass e, Show e) =>
  Bool ->
  CGraph n e ->
  (CGraphL n e, (Map.Map GraphMoveX [UINode], Map.Map Int [Column]))
layeredGraphAndCols :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
Bool
-> CGraph n e
-> (CGraphL n e, (Map Int [UINode], Map Int [Column]))
layeredGraphAndCols Bool
cross CGraph n e
graph = (CGraphL n e
g, forall e n.
EdgeClass e =>
CGraphL n e -> (Map Int [UINode], Map Int [Column])
getColumns CGraphL n e
g)
  where
    g :: CGraphL n e
g = forall n e.
(Unbox UINode, NodeClass n, Show n, EdgeClass e, Show e) =>
Bool -> CGraph n e -> CGraphL n e
layeredGraph Bool
cross CGraph n e
graph

-- Debug with https://dreampuf.github.io/GraphvizOnline using neato or fdp engine

-- ^ Layout a directed acyclic graph in several steps (Sugiyama)
-- 1. Assign the nodes to several layers (longest path)
-- 2. Dummy vertices for lines that are longer than a layer
-- 3. Reduce crossings, place the longest path on top
-- 4. Assign y-coordinates to the nodes so that long lines that pass several layers are
--    as straight as possible

layeredGraph ::
  (VU.Unbox UINode, NodeClass n, Show n, EdgeClass e, Show e) =>
  Bool ->
  CGraph n e ->
  CGraphL n e
layeredGraph :: forall n e.
(Unbox UINode, NodeClass n, Show n, EdgeClass e, Show e) =>
Bool -> CGraph n e -> CGraphL n e
layeredGraph Bool
cross CGraph n e
graph =
  -- Debug.Trace.trace ("layered "++ show graph ++"\n") -- ++ showEdges graph ++ show (Graph.edgeLabels graph)) $ -- ++"\nnewGraph\n" ++ show newGraph ++"\n") $
  CGraphL n e
newGraph
  where
    sortLayers :: (a, [[a]]) -> (a, [[a]])
sortLayers (a
gr, [[a]]
ls) = (a
gr, forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> [a]
sort [[a]]
ls) -- makes the dummy vertices appear lower
    newGraph :: CGraphL n e
newGraph =
      ( -- subgraphWindows .
        forall n e.
(NodeClass n, EdgeClass e) =>
(CGraph n e, [[UINode]]) -> CGraphL n e
yCoordinateAssignement
          -- .
          -- primitiveYCoordinateAssignement
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
Int -> Bool -> (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
crossingReduction Int
1 Bool
cross
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. Ord a => (a, [[a]]) -> (a, [[a]])
sortLayers
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionVertices
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> (CGraph n e, [[UINode]])
longestPathAlgo
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> CGraph n e
addMissingInputNodes -- does not change the graph, only computes layers
      )
        CGraph n e
graph

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

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

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 (graph,layers,ns)) $
  (CGraph n e
graph, 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[((Int, Int), UINode)]
layer Int
i -> forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b} {a}. Num a => a -> ((a, b), a) -> (a, (a, b))
incX Int
i) [((Int, Int), UINode)]
layer) (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. (a -> a) -> a -> [a]
iterate 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 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 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, EdgeClass e) => (CGraph n e, [[UINode]]) -> CGraphL n e
yCoordinateAssignement :: forall n e.
(NodeClass n, EdgeClass e) =>
(CGraph n e, [[UINode]]) -> CGraphL n e
yCoordinateAssignement (CGraph n e
graph, [[UINode]]
layers) =
  -- Debug.Trace.trace ("\nyCoordAssign "++ show (layers,graph,pos)) $
  (CGraph n e
graph, Map UINode (Int, Int)
pos)
  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)
-> Map UINode (Int, Int)
-> Map UINode (Int, Int)
horizontalBalancing Map UINode (Int, Int)
lu Map UINode (Int, Int)
ld Map UINode (Int, Int)
ru Map UINode (Int, Int)
rd
    lu :: Map UINode (Int, Int)
lu = forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
yPos (Median, Median)
medians (forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers) (Bool
True, Bool
True)
    ld :: Map UINode (Int, Int)
ld = forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
yPos (Median, Median)
medians (forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers) (Bool
True, Bool
False)
    ru :: Map UINode (Int, Int)
ru = forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
yPos (Median, Median)
medians (forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers) (Bool
False, Bool
True)
    rd :: Map UINode (Int, Int)
rd = forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
yPos (Median, Median)
medians (forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers) (Bool
False, Bool
False)

    -- for debugging
    --      edgesToKeep :: [(Graph.DirEdge UINode, [UIEdge])]
    --      edgesToKeep = map (\(x,y) -> (Graph.DirEdge x y, fromJust (Graph.lookupEdge (Graph.DirEdge x y) graph))) $
    --                      concat $ map (sweep medians Map.empty 0 (True,True)) (tuples (reverse nLayers))

    yPos :: Map UINode Int
yPos = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UINode, Int)]]
enumLayers)
    enumLayers :: [[(UINode, Int)]]
enumLayers = forall a b. (a -> b) -> [a] -> [b]
map (\[UINode]
l -> forall a b. [a] -> [b] -> [(a, b)]
zip [UINode]
l [Int
0 ..]) [[UINode]]
layers
    nLayers :: [[(UINode, Bool)]]
nLayers = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map UINode -> (UINode, Bool)
connProp) [[UINode]]
layers
    connProp :: UINode -> (UINode, Bool)
connProp UINode
n = (UINode
n, forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isConnNode CGraph n e
graph UINode
n)

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

    getMedian :: (UINode, [UINode]) -> Maybe (UINode, MYN)
getMedian (UINode
n, [UINode]
ns1)
      | Int
l forall a. Eq a => a -> a -> Bool
== Int
0 -- Debug.Trace.trace "get l0" $
        =
        forall a. Maybe a
Nothing
      | Int
l forall a. Eq a => a -> a -> Bool
== Int
1 = forall a. a -> Maybe a
Just (UINode
n, (Int, (UINode, Bool)) -> MYN
Single (Int, (UINode, Bool))
rightMedian)
      | forall a. Integral a => a -> Bool
even Int
l -- Debug.Trace.trace ("get lmod2"++ show (nodeLbls,ns1,(n, (leftMedian, rightMedian)))) $
        =
        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)))) $
        =
        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 forall a. [a] -> Int -> a
!! ((Int
l forall a. Integral a => a -> a -> a
`div` Int
2) forall a. Num a => a -> a -> a
- Int
1))
        rightMedian :: (Int, (UINode, Bool))
rightMedian = (Int, UINode) -> (Int, (UINode, Bool))
addConnProp ([(Int, UINode)]
sorted forall a. [a] -> Int -> a
!! (Int
l forall a. Integral a => a -> a -> a
`div` Int
2))
        l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
ns1
        sorted :: [(Int, UINode)]
sorted = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {b} {b}. Ord a => (a, b) -> (a, b) -> Ordering
py [(Int, UINode)]
nodeLbls
        py :: (a, b) -> (a, b) -> Ordering
py (a
y0, b
_) (a
y1, b
_) = forall a. Ord a => a -> a -> Ordering
compare a
y0 a
y1
        nodeLbls :: [(Int, UINode)]
nodeLbls = forall a b. (a -> b) -> [a] -> [b]
map (\UINode
node -> (forall a. a -> Maybe a -> a
fromMaybe Int
0 (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
node Map UINode Int
yPos), UINode
node)) [UINode]
ns1
        addConnProp :: (Int, UINode) -> (Int, (UINode, Bool))
addConnProp (Int
y, UINode
node) = (Int
y, (UINode
node, forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isConnNode CGraph n 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) -> Map UINode (X, Y) -> Map UINode (X, Y)
horizontalBalancing :: Map UINode (Int, Int)
-> Map UINode (Int, Int)
-> Map UINode (Int, Int)
-> Map UINode (Int, Int)
-> Map UINode (Int, Int)
horizontalBalancing Map UINode (Int, Int)
lu Map UINode (Int, Int)
_ld Map UINode (Int, Int)
_ru Map UINode (Int, Int)
_rd =
  -- Debug.Trace.trace ("horizontalBalancing "++ show (lu,ru)) --  ++"\n"++ show ld ++"\n"++ show average)
  -- lu -- ld ru rd
  Map UINode (Int, Int)
lu

-- average = zipWith f lu ru
--        f :: (UINode,(X,Y)) -> (UINode,(X,Y)) -> (UINode,(X,Y))
--        f (n0,(x0,y0)) (n1,(x1,y1)) | n0 /= n1 = error "horizontalBalancing n0 /= n1 "
--                                    | otherwise = (n0, (x0, (y0+y1) `div` 2 ))

type X = Int

type Y = Int

type YN = (Y, (UINode, Bool))

data MYN
  = Single (Y, (UINode, Bool)) -- no medians because there is only one connection
  | Middle (Y, (UINode, Bool)) -- an odd number of connections has only one median
  | UpLowMedian (Y, (UINode, Bool)) (Y, (UINode, Bool))
  deriving (MYN -> MYN -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MYN -> MYN -> Bool
$c/= :: MYN -> MYN -> Bool
== :: MYN -> MYN -> Bool
$c== :: MYN -> MYN -> Bool
Eq, Eq 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
min :: MYN -> MYN -> MYN
$cmin :: MYN -> MYN -> MYN
max :: MYN -> MYN -> MYN
$cmax :: MYN -> MYN -> MYN
>= :: MYN -> MYN -> Bool
$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
compare :: MYN -> MYN -> Ordering
$ccompare :: MYN -> MYN -> Ordering
Ord, Int -> MYN -> [Char] -> [Char]
[MYN] -> [Char] -> [Char]
MYN -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [MYN] -> [Char] -> [Char]
$cshowList :: [MYN] -> [Char] -> [Char]
show :: MYN -> [Char]
$cshow :: MYN -> [Char]
showsPrec :: Int -> MYN -> [Char] -> [Char]
$cshowsPrec :: Int -> MYN -> [Char] -> [Char]
Show) -- an even number of connections has two medians

type Median = Map UINode MYN

biasedAlignment ::
  (NodeClass n, EdgeClass e) =>
  CGraph n e ->
  Map UINode Y ->
  (Median, Median) ->
  [[(UINode, Bool)]] ->
  (Bool, Bool) ->
  Map UINode (X, Y)
biasedAlignment :: forall n e.
(NodeClass n, EdgeClass e) =>
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 = forall k a. Map k a -> [k]
Map.keys Map UINode (Int, Int)
balign
    _removePositioned :: [UINode] -> [UINode]
_removePositioned [UINode]
ns = [UINode]
ns 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) $
      forall e n.
EdgeClass e =>
CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> (Bool, Bool)
-> Map UINode (Int, Int)
align CGraph n e
graph (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) [[(UINode, Bool)]]
layers) [(UINode, UINode)]
edgesToKeep (Bool, Bool)
dir
    edgesToKeep :: [(UINode, UINode)]
edgesToKeep = forall a. Ord a => [a] -> [a]
rmdups forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(MYN, MYN)] -> [(UINode, UINode)]
resolve forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
sweep2) (forall a. [a] -> [(a, a)]
tuples [[(UINode, Bool)]]
layers)
    _line :: (a, a) -> [Char]
_line (a
from, a
to) = [Char]
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
from forall a. [a] -> [a] -> [a]
++ [Char]
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
to
    _placeNodes :: [Char]
_placeNodes = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map (Int, (Int, (UINode, Bool))) -> [Char]
placeNode) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b. [a] -> [b] -> [(a, b)]
zip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a]
repeat) [Int
1 ..] (forall a b. (a -> b) -> [a] -> [b]
map (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))) = forall a. Show a => a -> [Char]
show UINode
n forall a. [a] -> [a] -> [a]
++ [Char]
" [pos=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
x forall a. [a] -> [a] -> [a]
++ [Char]
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (-Int
y) 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 = forall a. Ord a => [a] -> [a]
rmdups forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 = 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 (forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty) (Int
0, Int
0) ([(UINode, Bool)]
layer0, [(UINode, Bool)]
layer1) forall a. Set a
Set.empty
        allowedEdges :: Set.Set (UINode, UINode)
        allowedEdges :: Set (UINode, UINode)
allowedEdges = forall a. Ord a => [a] -> Set a
Set.fromList (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)
          | forall a. Maybe a -> Bool
isJust Maybe MYN
lu = forall a. a -> Maybe a
Just (UINode
n, UINode
dest)
          | Bool
otherwise = forall a. Maybe a
Nothing
          where
            dest :: UINode
dest = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Bool -> MYN -> (Int, (UINode, Bool))
getYN (forall a b. (a, b) -> a
fst (Bool, Bool)
dir) (forall a. Int -> Maybe a -> a
myFromJust Int
500 Maybe MYN
lu)
            lu :: Maybe MYN
lu = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n (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 :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
    sweep2 :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
sweep2 ([(UINode, Bool)]
layer0, [(UINode, Bool)]
_layer1) =
      -- Debug.Trace.trace ("sweep2 "++ show (layer0, layer1,es))
      [[(MYN, MYN)]]
es
      where
        es :: [[(MYN, MYN)]]
es = [forall a. [Maybe a] -> [a]
catMaybes (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)
          | forall a. Maybe a -> Bool
isJust Maybe MYN
lu Bool -> Bool -> Bool
&& Bool
isValidEdge -- Debug.Trace.trace ("sweep2lu0 "++ show lu) $
            =
            forall a. a -> Maybe a
Just ((Int, (UINode, Bool)) -> MYN
Single (Int
y, (UINode
n, Bool
b)), forall a. Int -> Maybe a -> a
myFromJust Int
501 Maybe MYN
lu)
          | Bool
otherwise -- Debug.Trace.trace ("sweep2lu1 "++ show (n,lu))
            =
            forall a. Maybe a
Nothing
          where
            lu :: Maybe MYN
lu = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n (forall a b. (a, b) -> b
snd (Median, Median)
medians)
            luBack :: Maybe MYN
luBack = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
left forall a b. (a -> b) -> a -> b
$ forall a. Int -> Maybe a -> a
myFromJust Int
502 Maybe MYN
lu) (forall a b. (a, b) -> a
fst (Median, Median)
medians)
            isValidEdge :: Bool
isValidEdge =
              -- Debug.Trace.trace ("n,lu,luBack "++ show (n,lu,luBack)) $
              forall a. Maybe a -> Bool
isJust Maybe MYN
luBack Bool -> Bool -> Bool
&& UINode
n forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
left forall a b. (a -> b) -> a -> b
$ 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)

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

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
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer1 = forall a. [Char] -> a -> a
Debug.Trace.trace ([Char]
"nullnull " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([(UINode, Bool)]
layer0, [(UINode, Bool)]
layer1)) []
  | Int
y0 forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
|| Int
y1 forall a. Ord a => a -> a -> Bool
>= Int
10 = forall a. [Char] -> a -> a
Debug.Trace.trace ([Char]
"1010 " forall a. [a] -> [a] -> [a]
++ 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
    (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UINode, Bool)]
layer1 forall a. Ord a => a -> a -> Bool
>= Int
2) Bool -> Bool -> Bool
&& Bool
verticalNode Bool -> Bool -> 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" $
    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 forall a. Num a => a -> a -> a
+ Int
1) ([(UINode, Bool)]
layer0, [(UINode, Bool)]
tl1) forall a. Set a
Set.empty
  | forall k a. Map k a -> Bool
Map.null Map Int (MYN, MYN)
sweepedOverFrom Bool -> Bool -> 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 forall a. a -> [a] -> [a]
: (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 forall a. Num a => a -> a -> a
+ Int
1, Int
y1 forall a. Num a => a -> a -> a
+ Int
1) ([(UINode, Bool)]
tl0, [(UINode, Bool)]
tl1) forall a. Set a
Set.empty)
  | forall k a. Map k a -> Int
Map.size Map Int (MYN, MYN)
sweepedOverFrom forall a. Ord a => a -> a -> Bool
< 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") $
    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 forall a. Num a => a -> a -> a
+ Int
1, Int
y1)
      ([(UINode, Bool)]
tl0, [(UINode, Bool)]
layer1)
      (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") $
    =
    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 forall a. Num a => a -> a -> a
+ Int
1)
      ([(UINode, Bool)]
layer0, [(UINode, Bool)]
tl1)
      (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) = forall a. Int -> [a] -> a
myhead Int
60 [(UINode, Bool)]
layer0
    (UINode
n1, Bool
b1) = forall a. Int -> [a] -> a
myhead Int
61 [(UINode, Bool)]
layer1
    tl0 :: [(UINode, Bool)]
tl0
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer0 = []
      | Bool
otherwise = forall a. [a] -> [a]
tail [(UINode, Bool)]
layer0
    tl1 :: [(UINode, Bool)]
tl1
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer1 = []
      | Bool
otherwise = forall a. [a] -> [a]
tail [(UINode, Bool)]
layer1
    hl1 :: UINode
hl1 = forall a b. (a, b) -> a
fst (forall a. Int -> [a] -> a
myhead Int
62 [(UINode, Bool)]
layer1)
    verticalNode :: Bool
verticalNode = forall a. (Unbox a, Eq a) => a -> Vector a -> Bool
VU.elem (forall a b. (a, b) -> a
fst (forall a. Int -> [a] -> a
myhead Int
63 [(UINode, Bool)]
tl1)) (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 = forall a. Ord a => [a] -> [a]
myNub (forall k a. Map k a -> [a]
Map.elems Map Int (MYN, MYN)
newInsFrom forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map Int (MYN, MYN)
newInsTo forall a. [a] -> [a] -> [a]
++ forall a. Set a -> [a]
Set.toList Set (MYN, MYN)
missingEdges)

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

    newInsTo :: Map Int (MYN, MYN)
    newInsTo :: Map Int (MYN, MYN)
newInsTo
      | forall a. Maybe a -> Bool
isJust Maybe MYN
edgeTo Bool -> Bool -> Bool
&& Int
yy0 forall a. Ord a => a -> a -> Bool
>= Int
y0 = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
yy0 (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 (forall a. Int -> Maybe a -> a
myFromJust Int
506 Maybe MYN
edgeTo)

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

    sweepedOverFrom :: Map Int (MYN, MYN)
sweepedOverFrom = 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 = 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
forall a. Eq a => EdgeTy a -> EdgeTy a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeTy a -> EdgeTy a -> Bool
$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
Eq, Int -> EdgeTy a -> [Char] -> [Char]
forall a. Show a => Int -> EdgeTy a -> [Char] -> [Char]
forall a. Show a => [EdgeTy a] -> [Char] -> [Char]
forall a. Show a => EdgeTy a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [EdgeTy a] -> [Char] -> [Char]
$cshowList :: forall a. Show a => [EdgeTy a] -> [Char] -> [Char]
show :: EdgeTy a -> [Char]
$cshow :: forall a. Show a => EdgeTy a -> [Char]
showsPrec :: Int -> EdgeTy a -> [Char] -> [Char]
$cshowsPrec :: forall a. Show a => Int -> EdgeTy a -> [Char] -> [Char]
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)) $
  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)

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)

-- | 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 forall a. Ord a => a -> a -> Bool
> Int
20 -- Debug.Trace.trace ("ch1 "++ show (e0:edges))
    =
    (MYN, MYN)
e0 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 forall a. a -> [a] -> [a]
: ((Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
left, Bool
up) [(MYN, MYN)]
removeInferiorToE0 (Int
i forall a. Num a => a -> a -> a
+ Int
1))
  | 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EdgeTy (MYN, MYN)]
conflictList
      then (MYN, MYN)
e0 forall a. a -> [a] -> [a]
: [(MYN, MYN)]
edges
      else (MYN, MYN)
e0 forall a. a -> [a] -> [a]
: ((Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
left, Bool
up) [(MYN, MYN)]
edges (Int
i 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 forall a. Num a => a -> a -> a
+ Int
1)
  where
    conflictList :: [EdgeTy (MYN, MYN)]
conflictList = 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 forall a. a -> [a] -> [a]
: (forall a. (a -> Bool) -> [a] -> [a]
filter (\(MYN, MYN)
e -> (MYN, MYN)
e forall a. Eq a => a -> a -> Bool
/= (MYN, MYN)
e0 Bool -> Bool -> Bool
&& (MYN, MYN)
e forall a. Eq a => a -> a -> Bool
/= (MYN, MYN)
e1) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. EdgeTy a -> [a]
toEdges [EdgeTy (MYN, MYN)]
conflictList))
    e1 :: (MYN, MYN)
e1 = forall a. [a] -> a
head (forall {a}. EdgeTy a -> [a]
toEdges EdgeTy (MYN, MYN)
firstE1)
    firstE1 :: EdgeTy (MYN, MYN)
firstE1 = forall a. Int -> Maybe a -> a
myFromJust Int
511 (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find 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 = forall a. Ord a => [a] -> [a]
rmdups forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. EdgeTy a -> [a]
toEdges (forall a. (a -> Bool) -> [a] -> [a]
filter 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 [] = 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) = forall {a}. [EdgeTy a] -> EdgeTy Bool
isAllE0OrNoIntersect [EdgeTy (MYN, MYN)]
es
  where
    isAllE0OrNoIntersect :: [EdgeTy a] -> EdgeTy Bool
isAllE0OrNoIntersect [] = 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]
_) = forall a. a -> EdgeTy a
E0Prevails Bool
False -- not consistent
isConsistent ((E1Prevails (MYN, MYN)
_) : [EdgeTy (MYN, MYN)]
es) = forall {a}. [EdgeTy a] -> EdgeTy Bool
isAllE1OrNoIntersect [EdgeTy (MYN, MYN)]
es
  where
    isAllE1OrNoIntersect :: [EdgeTy a] -> EdgeTy Bool
isAllE1OrNoIntersect [] = 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]
_) = 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 = 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 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 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 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 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)) $
    =
    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)) $
    =
    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)) $
        forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1)
      else 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)) $
    =
    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)) $
    =
    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 forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1)
      else forall a. a -> EdgeTy a
E1Prevails (MYN
n2, MYN
n3)
  | Bool
otherwise = forall a. [Char] -> a -> a
Debug.Trace.trace [Char]
"cases err" forall a b. (a -> b) -> a -> b
$ 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
      | forall a. Num a => a -> a
abs (Bool -> MYN -> Int
getY Bool
left MYN
n0 forall a. Num a => a -> a -> a
- Bool -> MYN -> Int
getY Bool
left MYN
n1) forall a. Ord a => a -> a -> Bool
< forall a. Num a => a -> a
abs (Bool -> MYN -> Int
getY Bool
left MYN
n2 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

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]

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

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

--------------------------------------------------------------------------------------------------------------------

-- Similar to Brandes-Köpf but without arrays and no placement of blocks
-- The basic algorithm is longest path.
-- debugging can be done with graphviz, also uncomment line 533 in longestPath | otherwise
align :: EdgeClass e => CGraph n e -> [[UINode]] -> [(UINode, UINode)] -> (Bool, Bool) -> Map UINode (Int, Int)
align :: forall e n.
EdgeClass e =>
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\ndigraph{\n"++ (concat $ map ranksame layers)
                      ++ (concat (map ((++ "\n") . (intercalate " -> ") . (map show)) layers))
                      ++ (graphviz "[color=red,penwidth=2];" edges)
                      ++ (graphviz "" es) ++ "}\n"
                      ++ show (startNs, map last (zipWith f [0..] layers))
                      ++"\nblocks\n"++ show blocks ++ "\nnextInLayerMap" ++ show nextInLayerMap
                    )-}
  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 (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, (Int, Int))]
lp)
    lp :: [(UINode, (Int, Int))]
lp = [[(Int, UINode)]] -> [UINode] -> Int -> [(UINode, (Int, Int))]
longestPath (forall a b. (a -> b) -> [a] -> [b]
map (Int, UINode) -> [(Int, UINode)]
blockChildren [(Int, UINode)]
startNs) [] Int
0
    --        globalYMin = minimum (map (snd . snd) lp)
    --        lpBackwards = longestPath (map blockChildren startNsBackwards) [] 0
    layerConnections :: Map UINode UINode
layerConnections = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. [a] -> [(a, a)]
tuples [[UINode]]
layers
    reverseLayerConnections :: Map UINode UINode
reverseLayerConnections = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [a] -> [(a, a)]
tuples forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse) [[UINode]]
layers
    edgeMap :: Map UINode UINode
edgeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, UINode)]
edges
    reverseBlocks :: Map UINode UINode
reverseBlocks = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(UINode, UINode)]
edges)
    _es :: [(UINode, UINode)]
_es = forall k a. Map k a -> [k]
Map.keys (forall nl el. Graph nl el -> Map (UINode, UINode) el
Graph.edgeLabels CGraph n e
graph) forall a. Eq a => [a] -> [a] -> [a]
\\ [(UINode, UINode)]
edges

    startNs :: [(Int, UINode)]
startNs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Int, UINode) -> Maybe (Int, UINode)
nodeWithoutParent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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 = forall a b. (a -> b) -> [a] -> [b]
map (t
i,) [a]
ns

    nodeWithoutParent :: (Int, UINode) -> Maybe (Int, UINode)
nodeWithoutParent (Int
x, UINode
n)
      | forall a. Maybe a -> Bool
isNothing (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))) $
        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))) $
        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))) $
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, UINode) -> Bool
hasNoLayerParent ((Int, UINode) -> [(Int, UINode)]
blockChildren (Int, UINode)
root)

        hasNoLayerParent :: (Int, UINode) -> Bool
hasNoLayerParent (Int
_, UINode
_n) = forall a. Maybe a -> Bool
isNothing (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
layerConnections)

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

    longestPath :: [[(X, UINode)]] -> [UINode] -> Int -> [(UINode, (Int, Int))]
    longestPath :: [[(Int, UINode)]] -> [UINode] -> Int -> [(UINode, (Int, Int))]
longestPath [] [UINode]
_ Int
_ =
      -- Debug.Trace.trace "finish"
      []
    longestPath [[(Int, UINode)]]
blockNodes [UINode]
used Int
i
      | Int
i 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") $
      --      ++ "map layerChild " ++ show (map layerChild (concat blockNodes)) ++ "\n"
      --      ++ "nextLayerRoots " ++ show nextLayerRoots ++ "\n"
      --      ++ "map blockChildren nextLayerRoots " ++ show (map blockChildren nextLayerRoots) ++ "\n"
      --      ++ "blocksWithOnlyUsedParents " ++ show blocksWithOnlyUsedParents ++ "\n"
      --      ++ "newUsed " ++ show newUsed
      --                ) $
        =
        [(UINode, (Int, Int))]
newLayer forall a. [a] -> [a] -> [a]
++ [[(Int, UINode)]] -> [UINode] -> Int -> [(UINode, (Int, Int))]
longestPath [[(Int, UINode)]]
blocksWithOnlyUsedParents [UINode]
newUsed (Int
i forall a. Num a => a -> a -> a
+ Int
1)
      where
        newLayer :: [(UINode, (Int, Int))]
newLayer = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [(Int, UINode)] -> [(UINode, (Int, Int))]
oneLayer Int
i) [[(Int, UINode)]]
blockNodes
        blocksWithOnlyUsedParents :: [[(Int, UINode)]]
blocksWithOnlyUsedParents = forall a. Ord a => [a] -> [a]
rmdups forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter [(Int, UINode)] -> Bool
noParentOrUsed (forall a b. (a -> b) -> [a] -> [b]
map (Int, UINode) -> [(Int, UINode)]
blockChildren [(Int, UINode)]
nextLayerRoots)
        --                                          | otherwise = rmdups $ filter noParentOrUsed (map blockChildren nextLayerRootsBackwards)
        nextLayerRoots :: [(Int, UINode)]
nextLayerRoots = [(Int, UINode)] -> [(Int, UINode)]
myNub2 (forall a b. (a -> b) -> [a] -> [b]
map (Int, UINode) -> (Int, UINode)
findRoot [(Int, UINode)]
nextPossibleLayerNodes)
        --                nextLayerRootsBackwards = myNub2 (map findRoot nextPossibleLayerNodesBackwards)
        nextPossibleLayerNodes :: [(Int, UINode)]
nextPossibleLayerNodes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, UINode) -> Maybe (Int, UINode)
layerChild (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, UINode)]]
blockNodes)
        --                nextPossibleLayerNodesBackwards = catMaybes (map layerParent (concat blockNodes))
        layerChild :: (Int, UINode) -> Maybe (Int, UINode)
layerChild (Int
x, UINode
n) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (\UINode
node -> forall a. a -> Maybe a
Just (Int
x, UINode
node)) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
reverseLayerConnections)
        --                layerParent (x,n) = maybe Nothing (\node -> Just (x,node)) (Map.lookup n layerConnections)
        newUsed :: [UINode]
newUsed = [UINode]
used forall a. [a] -> [a] -> [a]
++ [UINode]
blns
        blns :: [UINode]
blns = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, UINode)]]
blockNodes)
        noParentOrUsed :: [(Int, UINode)] -> Bool
noParentOrUsed [(Int, UINode)]
block =
          -- Debug.Trace.trace ("noParentOrUsed "++ show (block, map noParOrUsed block, newUsed)) $
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, UINode) -> Bool
noParOrUsed [(Int, UINode)]
block
        noParOrUsed :: (Int, UINode) -> Bool
noParOrUsed (Int
_, UINode
n) =
          -- Debug.Trace.trace ("noParOrUsed "++ show (n,lu)) $
          forall a. Maybe a -> Bool
isNothing Maybe UINode
lu Bool -> Bool -> Bool
|| (forall a. Maybe a -> Bool
isJust Maybe UINode
lu Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall a. Int -> Maybe a -> a
myFromJust Int
514 Maybe UINode
lu) [UINode]
newUsed)
          where
            lu :: Maybe UINode
lu = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
layerConnections

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

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

    blocks :: [[UINode]]
blocks = [[UINode]]
extr forall a. [a] -> [a] -> [a]
++ (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 = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UINode]]
layers forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
allNodes) forall a. Eq a => [a] -> [a] -> [a]
\\ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UINode]]
extr
        allNodes :: [UINode]
allNodes = forall k a. Map k a -> [k]
Map.keys Map UINode UINode
edgeMap forall a. [a] -> [a] -> [a]
++ 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
      | forall k a. Map k a -> Bool
Map.null Map UINode UINode
m = []
      | Bool
otherwise = [[UINode]]
oneBlock 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) $
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Map UINode UINode
m (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UINode]]
oneBlock)
        oneBlock :: [[UINode]]
oneBlock =
          forall a. (a -> Bool) -> [a] -> [a]
filter
            (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
            ( forall {a}. [[a]] -> [[a]]
merge1 (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts)
                forall a. [a] -> [a] -> [a]
++ [forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts]
                forall a. [a] -> [a] -> [a]
++ forall {a}. [[a]] -> [[a]]
merge1 (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts)
            )
        merge1 :: [[a]] -> [[a]]
merge1 [] = []
        merge1 [[a]]
xs = (forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head [[a]]
fil) forall a. a -> [a] -> [a]
: ([[a]] -> [[a]]
merge1 (forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [a]
tail [[a]]
fil))
          where
            fil :: [[a]]
fil = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
xs
        oneBlockWithVerts :: [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts =
          -- Debug.Trace.trace ("oneBlock " ++ show (reverse (blockNodesDown (head ks)), tail (blockNodesUp (head ks)))) $
          forall a. [a] -> [a]
reverse (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesDown (forall a. [a] -> a
head [UINode]
ks))
            forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
tail (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesUp (forall a. [a] -> a
head [UINode]
ks))

        ks :: [UINode]
ks = forall k a. Map k a -> [k]
Map.keys Map UINode UINode
m forall a. [a] -> [a] -> [a]
++ 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
          | forall a. Maybe a -> Bool
isJust Maybe UINode
lu = (UINode
n, ([UINode]
vertup, [UINode]
vertdown)) forall a. a -> [a] -> [a]
: (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesDown (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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
edgeMap
            vertup :: [UINode]
vertup = forall a. Unbox a => Vector a -> [a]
VU.toList (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsVertical CGraph n e
graph UINode
n)
            vertdown :: [UINode]
vertdown = forall a. Unbox a => Vector a -> [a]
VU.toList (forall e n. EdgeClass e => Graph 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
          | forall a. Maybe a -> Bool
isJust Maybe UINode
lu = (UINode
n, ([UINode]
vertup, [UINode]
vertdown)) forall a. a -> [a] -> [a]
: (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesUp (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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
reverseBlocks
            vertup :: [UINode]
vertup = forall a. Unbox a => Vector a -> [a]
VU.toList (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsVertical CGraph n e
graph UINode
n)
            vertdown :: [UINode]
vertdown = forall a. Unbox a => Vector a -> [a]
VU.toList (forall e n. EdgeClass e => Graph 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)))
      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 (forall a. [a] -> [a]
reverse [[UINode]]
blocks)
    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)))
      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) (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
      | 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))
        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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> a
fst [(Maybe Int, Maybe Int)]
bounds
        newY :: Int
newY = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bs forall a. Num a => a -> a -> a
+ Int
1 -- TODO look at block connections
        bounds :: [(Maybe Int, Maybe Int)]
bounds = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
b Map UINode (Int, Int)
m)
            n :: Maybe UINode
n = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
b Map UINode UINode
nextInLayerMap

    nextInLayerMap :: Map UINode UINode
nextInLayerMap = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k}. Ord k => [k] -> Map k k -> Map k k
addLayerEdges 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k} {a}. Ord k => (a, k) -> Map k a -> Map k a
addEdge Map k k
m (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 = 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 = 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 = 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

---------------------------------------------------------------------------------------------------------

-- The idea behind the following heuristic:
-- Very frequent chaining of functions are obvious and need no attention, e.g. Data.Text.pack str
-- unusual chainings need the highest attention
-- a long path means it is the main path of activity, like a table of contents in a book that
-- is a guide where to go. This long path should be a straight line at the top of the page.

-- Sort nodes in the layers by:
--   Finding the longest path with the most infrequent connections, make these nodes appear
--   first (y=0) use dfs to find the second longest/infrequent path
-- longestinfrequentPaths :: CGraph -> [[Node]] -> [Node]

type YNode = (YPos, Channel, UINode, IsDummy)

type YPos = Word32

type IsDummy = Bool

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

leftToRight :: Dir -> Bool
leftToRight :: Dir -> Bool
leftToRight Dir
LeftToRight = Bool
True
leftToRight Dir
RightToLeft = Bool
False

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
_ [] = forall a. Unbox a => Vector a
VU.empty
longestinfrequentPaths CGraph n e
_ [[UINode]
_] = forall a. Unbox a => Vector a
VU.empty
longestinfrequentPaths CGraph n e
g ([UINode]
l0 : [UINode]
l1 : [[UINode]]
layers)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vector Int]
r = forall a. Unbox a => Vector a
VU.empty
  | Bool
otherwise = forall a. Unbox a => Int -> Vector a -> Vector a
VU.take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[UINode]]
layers forall a. Num a => a -> a -> a
+ Int
2) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> a
myhead Int
64 [Vector Int]
r
  where
    r :: [Vector Int]
r = forall a b. (a -> b) -> [a] -> [b]
map (forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
liPaths CGraph n e
g ([UINode]
l1 forall a. a -> [a] -> [a]
: [[UINode]]
layers) []) (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 = 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
      | forall a. Unbox a => Vector a -> Bool
VU.null forall a b. (a -> b) -> a -> b
$
          forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter
            (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UINode]
layer1)
            (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node) =
        forall a. Maybe a
Nothing
      | Bool
otherwise = 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 = forall a. Unbox a => [a] -> Vector a
VU.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral (UINode
node forall a. a -> [a] -> [a]
: [UINode]
ns))
liPaths CGraph n e
g ([UINode]
l0 : [[UINode]]
layers) [UINode]
ns UINode
node = forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap (forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
liPaths CGraph n e
g [[UINode]]
layers (UINode
node forall a. a -> [a] -> [a]
: [UINode]
ns)) Vector UINode
cs
  where
    cs :: Vector UINode
cs =
      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 (forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
g UINode
x) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
x [UINode]
l0)
        (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node)

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

myNub2 :: [(Int, UINode)] -> [(Int, UINode)]
myNub2 :: [(Int, UINode)] -> [(Int, UINode)]
myNub2 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> a
myhead Int
66) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy forall {a} {a} {a}. Eq a => (a, a) -> (a, a) -> Bool
nnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {a} {a}. Ord a => (a, a) -> (a, a) -> Ordering
nn
  where
    nn :: (a, a) -> (a, a) -> Ordering
nn (a
_, a
n0) (a
_, a
n1) = 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 forall a. Eq a => a -> a -> Bool
== a
n1

type UnconnectedChildren = [UINode]

-- | Every graph has a longest path, which is the center of attention for us
-- Return layers of node ids
-- This algorithm is a little bit more complicated because we can connect nodes "vertically",
-- so that they are guaranteed to be all in one vertical layer
-- All nodes before this vertical layer have to be placed in layers before we can proceed
longestPathAlgo :: (NodeClass n, EdgeClass e) => CGraph n e -> (CGraph n e, [[UINode]])
longestPathAlgo :: forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> (CGraph n e, [[UINode]])
longestPathAlgo CGraph n e
g =
  -- Debug.Trace.trace ("\nlongestPathAlgo\n" ++ show (g, newLayers, moveFinalNodesLeftToVert newLayers)) $
  --  Debug.Trace.trace ("\nlongestPathAlgo " ++ show g ++
  --                     "\nnewLayers" ++ show newLayers ++
  --                     "\nnodesWithoutChildren" ++ show nodesWithoutChildren ++
  --                     "\nverticalLayers" ++ show verticalLayers ++
  --                     "\noptionNodes" ++ show optionNodes ++
  --                     "\nnodesWithoutChildrenVertLayer" ++ show nodesWithoutChildrenVertLayer ++
  --                     "\n"++ showEdges g)
  (CGraph n e
g, [[UINode]] -> [[UINode]]
moveFinalNodesLeftToVert (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> [a]
rmdups [[UINode]]
newLayers))
  where
    moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]]
    moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]]
moveFinalNodesLeftToVert [[UINode]]
ls =
      -- Debug.Trace.trace ("nodesToMove "++ show (nodesToMove, nodesAndPrevious)) $
      (forall a. Int -> [a] -> a
myhead Int
67 [[UINode]]
ls forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
nodesToMove) forall a. a -> [a] -> [a]
: (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. Eq a => (a, a) -> [[a]] -> [[a]]
insert (forall a. [a] -> [a]
tail [[UINode]]
ls) [(UINode, UINode)]
nodesAndPrevious)
      where
        nodesToMove :: [UINode]
nodesToMove
          | forall (t :: * -> *) a. Foldable t => t a -> Int
length [[UINode]]
ls forall a. Ord a => a -> a -> Bool
< Int
2 = []
          | Bool
otherwise = forall a. (a -> Bool) -> [a] -> [a]
filter ([UINode] -> Bool
notEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Unbox a => Vector a -> [a]
VU.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g) (forall a. Int -> [a] -> a
myhead Int
68 [[UINode]]
ls)
        notEl :: [UINode] -> Bool
notEl [UINode
n] = UINode
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. Int -> [a] -> a
myhead Int
69 (forall a. [a] -> [a]
tail [[UINode]]
ls)
        notEl [UINode]
_ = Bool
False
        insert :: (a, a) -> [[a]] -> [[a]]
insert (a
n, a
p) [[a]]
lays
          | 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 = forall {a}. [[a]] -> Int -> a -> [[a]]
add [[a]]
lays (forall a. [a] -> a
head [Int]
fpl) a
n
          where
            fpl :: [Int]
fpl = forall {a} {t :: * -> *} {a}.
(Num a, Enum a, Foldable t, Eq a) =>
a -> [t a] -> [a]
findn a
p [[a]]
lays
        nodesAndPrevious :: [(UINode, UINode)]
nodesAndPrevious = forall a b. [a] -> [b] -> [(a, b)]
zip [UINode]
nodesToMove (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Unbox a => Vector a -> a
VU.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g) [UINode]
nodesToMove)
        add :: [[a]] -> Int -> a -> [[a]]
add [[a]]
list Int
pos a
n = forall a. Int -> [a] -> [a]
take (Int
pos forall a. Num a => a -> a -> a
- Int
1) [[a]]
list forall a. [a] -> [a] -> [a]
++ (([[a]]
list forall a. [a] -> Int -> a
!! (Int
pos forall a. Num a => a -> a -> a
- Int
1)) forall a. [a] -> [a] -> [a]
++ [a
n]) forall a. a -> [a] -> [a]
: (forall a. Int -> [a] -> [a]
drop Int
pos [[a]]
list)
        findn :: a -> [t a] -> [a]
findn a
p [t a]
l = [forall a b. (a, b) -> a
fst (a, t a)
il | (a, t a)
il <- forall a b. [a] -> [b] -> [(a, b)]
zip [a
0 ..] [t a]
l, a
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a, b) -> b
snd (a, t a)
il]

    newLayers :: [[UINode]]
newLayers = [UINode] -> [([UINode], [UINode], Bool)] -> [UINode] -> [[UINode]]
layersrec (forall a. Ord a => [a] -> [a]
rmdups forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList Vector UINode
nodesWithoutChildrenVertLayer) [([UINode], [UINode], Bool)]
fil []
    fil :: [([UINode], [UINode], Bool)]
fil = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> b
sel2) [([UINode], [UINode], Bool)]
verticalLayers
    sel1 :: (a, b, c) -> a
sel1 (a
x, b
_, c
_) = a
x
    sel2 :: (a, b, c) -> b
sel2 (a
_, b
y, c
_) = b
y
    ns :: Vector UINode
ns = forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Unbox a => [a] -> Vector a
VU.fromList (forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
g))
    nodesWithoutChildren :: Vector UINode
nodesWithoutChildren = forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter (forall a. Unbox a => Vector a -> Bool
VU.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. UINode -> Vector UINode
cs) Vector UINode
ns
    nodesWithoutChildrenVertLayer :: VU.Vector UINode
    nodesWithoutChildrenVertLayer :: Vector UINode
nodesWithoutChildrenVertLayer =
      -- Debug.Trace.trace ("nwcvl "++ show (nodesWithoutChildren, nwcvl))
      Vector UINode
nwcvl
      where
        nwcvl :: Vector UINode
nwcvl = forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap ([[UINode]] -> UINode -> Vector UINode
findLayers (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
sel1 [([UINode], [UINode], Bool)]
verticalLayers)) Vector UINode
nodesWithoutChildren
    findLayers :: [[UINode]] -> UINode -> VU.Vector UINode
    findLayers :: [[UINode]] -> UINode -> Vector UINode
findLayers [[UINode]]
ls UINode
n
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[UINode]]
ls = forall a. Unbox a => a -> Vector a
VU.singleton UINode
n
      | Bool
otherwise = forall a. Unbox a => [a] -> Vector a
VU.fromList (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map [UINode] -> [UINode]
findL [[UINode]]
ls))
      where
        findL :: [UINode] -> [UINode]
findL [UINode]
l
          | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
n [UINode]
l = [UINode]
l
          | Bool
otherwise = [UINode
n]
    cs :: UINode -> Vector UINode
cs UINode
node = forall el nl.
EdgeAttribute el =>
Graph nl el -> UINode -> el -> Vector UINode
Graph.children CGraph n e
g UINode
node [forall e. EdgeClass e => Maybe Int -> Int -> e
dummyEdge forall a. Maybe a
Nothing Int
0]
    (Vector UINode
_, Vector UINode
optionNodes) = forall e n.
EdgeClass e =>
CGraph n e -> Vector UINode -> (Vector UINode, Vector UINode)
partitionNodes CGraph n e
g Vector UINode
ns -- nonOptionNodes
    verticalLayers :: [([UINode], [UINode], Bool)]
verticalLayers =
      -- Debug.Trace.trace (show ("verticalLayers", VU.toList optionNodes, vLayers (VU.toList optionNodes))) $
      [UINode] -> [([UINode], [UINode], Bool)]
vLayers (forall a. Unbox a => Vector a -> [a]
VU.toList Vector UINode
optionNodes)

    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) forall a. a -> [a] -> [a]
: ([UINode] -> [([UINode], [UINode], Bool)]
vLayers ([UINode]
ns1 forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
newLayer))
      where
        newLayer :: [UINode]
newLayer = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall e n. EdgeClass e => CGraph n e -> UINode -> [UINode]
verticallyConnectedNodes CGraph n e
g UINode
n
        addUnconnectedChildren :: [UINode] -> ([UINode], UnconnectedChildren, Bool)
        addUnconnectedChildren :: [UINode] -> ([UINode], [UINode], Bool)
addUnconnectedChildren [UINode]
layer1 = ([UINode]
layer1, forall a. Ord a => [a] -> [a]
myNub forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList (forall a. Unbox a => [Vector a] -> Vector a
VU.concat (forall a b. (a -> b) -> [a] -> [b]
map UINode -> Vector UINode
nonVertChildren [UINode]
layer1)), Bool
False)
        nonVertChildren :: UINode -> Vector UINode
nonVertChildren UINode
node = forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node

    -- the idea of this recursion is to go backwards from the final node and add non-vertical nodes that are fully connected at the input
    -- if there is only a vertical layer possible, add it
    layersrec :: [UINode] -> [([UINode], UnconnectedChildren, Bool)] -> [UINode] -> [[UINode]]
    layersrec :: [UINode] -> [([UINode], [UINode], Bool)] -> [UINode] -> [[UINode]]
layersrec [UINode]
curLayer [([UINode], [UINode], Bool)]
vertLayers [UINode]
usedNodes
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
curLayer -- Debug.Trace.trace "\n§§1 "
        =
        []
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
usedNodes forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
curLayer forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
g) =
        forall a. [Char] -> a -> a
Debug.Trace.trace
          ([Char]
"\n§§2 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([UINode]
curLayer, forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
usedNodes, [UINode]
usedNodes, forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
curLayer, forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
g)))
          [[UINode]
curLayer] -- should not happen
      | Bool
otherwise {-Debug.Trace.trace ("\n§§3 curLayer "++ show curLayer ++
                                     "\nfullyConnectedVertNodes2 " ++ show fullyConnectedVertNodes2 ++
                                     "\nnewCurLayerOrVert " ++ show newCurLayerOrVert ++
                                     "\nusedNodes " ++ show usedNodes ++
                                     "\nlayerParents curLayer " ++ show (layerParents curLayer) ++
                                     "\nvertLayers    " ++ show vertLayers ++
                                     "\nnewVertLayers " ++ show newVertLayers ++
                                     "\nfil" ++ show fil)-} =
        [UINode]
curLayer forall a. a -> [a] -> [a]
: ([UINode] -> [([UINode], [UINode], Bool)] -> [UINode] -> [[UINode]]
layersrec [UINode]
newCurLayerOrVert [([UINode], [UINode], Bool)]
filtered ([UINode]
usedNodes forall a. [a] -> [a] -> [a]
++ [UINode]
curLayer))
      where
        newVertLayers :: [([UINode], [UINode], Bool)]
newVertLayers = 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, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
newun Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall n e. NodeClass n => CGraph n e -> UINode -> Bool
isNotMainFunctionArg CGraph n e
g) [UINode]
someLayer)
          where
            newun :: [UINode]
newun = [UINode]
unconnectedChildren forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
curLayer

        filtered :: [([UINode], [UINode], Bool)]
filtered
          | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
newCurLayer) -- Debug.Trace.trace ("fil0 "++ show (newVertLayers)) $
            =
            forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> c
changed) [([UINode], [UINode], Bool)]
newVertLayers
          | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
fullyConnectedVertNodes2) -- Debug.Trace.trace ("fil1 "++ show (filter (not . isFullyConnected) newVertLayers)) $
            =
            forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)) $
            =
            forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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))
        fullyConnectedVertNodes2 :: [UINode]
fullyConnectedVertNodes2 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b} {c}. (a, b, c) -> a
sel1 (forall a. (a -> Bool) -> [a] -> [a]
filter 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
_) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
unconnectedChildren

        newCurLayer :: [UINode]
newCurLayer =
          -- Debug.Trace.trace ("curParents"++ show (layerParents curLayer, filter shouldNodeBeAdded (layerParents curLayer))) $
          forall a. Ord a => [a] -> [a]
myNub (forall a. (a -> Bool) -> [a] -> [a]
filter UINode -> Bool
shouldNodeBeAdded ([UINode] -> [UINode]
layerParents [UINode]
curLayer)) forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b} {c}. (a, b, c) -> a
sel1 (forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {b} {c}. (a, b, c) -> c
changed [([UINode], [UINode], Bool)]
newVertLayers)
        changed :: (a, b, c) -> c
changed (a
_, b
_, c
b) = c
b
        layerParents :: [UINode] -> [UINode]
layerParents [UINode]
l = forall a. Unbox a => Vector a -> [a]
VU.toList (forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g) (forall a. Unbox a => [a] -> Vector a
VU.fromList [UINode]
l))
        newCurLayerOrVert :: [UINode]
newCurLayerOrVert
          | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
newCurLayer) -- Debug.Trace.trace "not (null newCurLayer)" $ --prefer normal nodes to vertical nodes
            =
            forall a. Ord a => [a] -> [a]
myNub [UINode]
newCurLayer
          | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
fullyConnectedVertNodes2) -- Debug.Trace.trace "not (null fullyConnectedVertNodes2)" $ --if no normal nodes are left
            =
            forall a. Ord a => [a] -> [a]
myNub [UINode]
fullyConnectedVertNodes2
          | Bool
otherwise = []
        shouldNodeBeAdded :: UINode -> Bool -- have all children been added, then node should be added
        shouldNodeBeAdded :: UINode -> Bool
shouldNodeBeAdded UINode
node
          | 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)) $
            =
            Vector Bool -> Bool
VU.and (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 = forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node
            isChildUsed :: UINode -> Bool
            isChildUsed :: UINode -> Bool
isChildUsed UINode
child = UINode
child forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([UINode]
usedNodes forall a. [a] -> [a] -> [a]
++ [UINode]
curLayer)
            isInVertLayer :: UINode -> Bool
            isInVertLayer :: UINode -> Bool
isInVertLayer UINode
n = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
sel1) [([UINode], [UINode], Bool)]
vertLayers

-- Some functions don't have an input (e.g. True).
-- But a function without input can only appear directly after a case node
-- That's why we insert a connection node between this case node and the function node
addMissingInputNodes :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> CGraph n e
addMissingInputNodes :: forall n e.
(NodeClass n, Show n, 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)))) $
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> UINode -> CGraph n e
addConnNode CGraph n e
graph (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral (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
      | forall a. Unbox a => Vector a -> Bool
VU.null Vector UINode
ps = CGraph n e
g
      | forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isFunction CGraph n e
graph UINode
n =
        --        && isCase graph (vhead 501 ps) -- Debug.Trace.trace ("caseconn"++ show (n, VU.head ps)) $

        forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> UINode -> UINode -> Maybe Int -> Int -> CGraph n e
insertConnNode CGraph n e
g UINode
n (forall a. Unbox a => Int -> Vector a -> a
vhead Int
502 Vector UINode
ps) forall a. Maybe a
Nothing Int
0
      | Bool
otherwise = CGraph n e
g
      where
        ps :: Vector UINode
ps = forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
graph 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 =
  forall a.
Unbox a =>
(a -> Bool) -> Vector a -> (Vector a, Vector a)
VU.partition
    ( \UINode
n ->
        forall a. Unbox a => Vector a -> Bool
VU.null (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsVertical CGraph n e
g UINode
n)
          Bool -> Bool -> Bool
&& forall a. Unbox a => Vector a -> Bool
VU.null (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenVertical CGraph n e
g UINode
n)
    )

-- coffmanGrahamAlgo :: Graph -> [[Int]]
-- coffmanGrahamAlgo g =

addConnectionVertices :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionVertices :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionVertices (CGraph n e
g, [[UINode]]
ls) =
  -- Debug.Trace.trace ("acv"++ show (ls, addConnectionVs (g,ls))) $
  forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionVs (CGraph n e
g, [[UINode]]
ls)

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

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

    innerSs :: [(UINode, UINode, (Maybe Int, Int))]
innerSs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UINode -> [(UINode, UINode, (Maybe Int, Int))]
innerSegments [UINode]
l0
    innerSegments :: UINode -> [(UINode, UINode, (Maybe Int, Int))]
innerSegments UINode
n =
      -- Debug.Trace.trace ("ps"++ show ps) $
      forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall a. a -> [a]
repeat UINode
n) [UINode]
notInLayerL1Parents [(Maybe Int, Int)]
chans
      where
        notInLayerL1Parents :: [UINode]
notInLayerL1Parents = forall a. Unbox a => Vector a -> [a]
VU.toList (forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter UINode -> Bool
isNotInLayerL1 Vector UINode
ps)
        ps :: Vector UINode
ps = forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
graph UINode
n
        isNotInLayerL1 :: UINode -> Bool
isNotInLayerL1 = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UINode]
l1)
        chans :: [(Maybe Int, Int)]
chans = forall a b. (a -> b) -> [a] -> [b]
map (\Maybe [e]
e -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Maybe a
Nothing, Int
0) forall {e}. EdgeClass e => [e] -> (Maybe Int, Int)
f Maybe [e]
e) [Maybe [e]]
edges
        f :: [e] -> (Maybe Int, Int)
f [e]
x = (forall e. EdgeClass e => e -> Maybe Int
channelNrIn (forall a. Int -> [a] -> a
myhead Int
71 [e]
x), forall e. EdgeClass e => e -> Int
channelNrOut (forall a. Int -> [a] -> a
myhead Int
72 [e]
x))
        edges :: [Maybe [e]]
edges = 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 = forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode
x, UINode
y) CGraph n e
graph

    dummyNodeEdge :: (NodeClass n, Show n, EdgeClass e) => (CGraph n e, [UINode]) -> (UINode, (UINode, UINode, (Maybe Int, Int))) -> (CGraph n e, [UINode])
    dummyNodeEdge :: forall n e.
(NodeClass n, Show n, EdgeClass e) =>
(CGraph n e, [UINode])
-> (UINode, (UINode, UINode, (Maybe Int, Int)))
-> (CGraph n e, [UINode])
dummyNodeEdge (CGraph n e
g, [UINode]
l) (UINode
v, (UINode
from, UINode
to, (Maybe Int
chanIn, Int
chanOut))) =
      -- Debug.Trace.trace ("dummyNodeEdge"++ show (v,(from,to,chan)))
      (forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> UINode -> UINode -> Maybe Int -> Int -> CGraph n e
insertConnNode CGraph n e
g UINode
from UINode
to Maybe Int
chanIn Int
chanOut, UINode
v forall a. a -> [a] -> [a]
: [UINode]
l)

insertConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> UINode -> Maybe Channel -> Channel -> CGraph n e
insertConnNode :: forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> UINode -> UINode -> Maybe Int -> Int -> CGraph n e
insertConnNode CGraph n e
graph UINode
from UINode
to Maybe Int
chanIn Int
chanOut =
  -- Debug.Trace.trace ("dummyNodeEdge"++ show (to, fromIntegral (m+1), chanIn, 0, chanOut, fromIntegral (m+1), from))
  forall el nl.
EdgeAttribute el =>
Maybe Bool -> (UINode, UINode) -> Graph nl el -> Graph nl el
Graph.deleteEdge (forall a. a -> Maybe a
Just Bool
True) (UINode
to, UINode
from) forall a b. (a -> b) -> a -> b
$
    forall el nl.
EdgeAttribute el =>
Maybe Bool -> (UINode, UINode) -> el -> Graph nl el -> Graph nl el
Graph.insertEdge (forall a. a -> Maybe a
Just Bool
True) (UINode
to, forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m forall a. Num a => a -> a -> a
+ Int
1)) [forall e. EdgeClass e => Maybe Int -> Int -> e
dummyEdge Maybe Int
chanIn Int
0] forall a b. (a -> b) -> a -> b
$
      forall el nl.
EdgeAttribute el =>
Maybe Bool -> (UINode, UINode) -> el -> Graph nl el -> Graph nl el
Graph.insertEdge
        (forall a. a -> Maybe a
Just Bool
True)
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m forall a. Num a => a -> a -> a
+ Int
1), UINode
from)
        [forall e. EdgeClass e => Maybe Int -> Int -> e
dummyEdge forall a. Maybe a
Nothing Int
chanOut]
        (forall el nl.
EdgeAttribute el =>
UINode -> nl -> Graph nl el -> Graph nl el
Graph.insertNode (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m forall a. Num a => a -> a -> a
+ Int
1)) forall n. NodeClass n => n
connectionNode CGraph n e
graph)
  where
    m :: Int
m = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
graph)
    nest :: Maybe LayerFeatures
nest
      | forall a. Maybe a -> Bool
isJust Maybe n
lu = forall n. NodeClass n => n -> Maybe LayerFeatures
Common.nestingFeatures (forall a. Int -> Maybe a -> a
myFromJust Int
516 Maybe n
lu)
      | Bool
otherwise = forall a. Maybe a
Nothing
    lu :: Maybe n
lu = forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode UINode
from CGraph n e
graph
    depth :: Int
depth = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 LayerFeatures -> Int
Common.layer Maybe LayerFeatures
nest

-- UIEdge 2 1 "" Curly "#ff5863" "" i False False]

crossingReduction :: (NodeClass n, Show n, EdgeClass e, Show e) => Int -> Bool -> (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
crossingReduction :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
Int -> Bool -> (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
crossingReduction Int
i Bool
longestP (CGraph n e
graph, [[UINode]]
layers)
  | Int
i forall a. Ord a => a -> a -> Bool
> Int
0 -- Debug.Trace.trace ("crossingReduction\nlayers    " ++ show layers ++
  --         "\nc         "++ show c ++
  --         "\nnewlayers "++ show newLayers) $
    =
    forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
Int -> Bool -> (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
crossingReduction (Int
i forall a. Num a => a -> a -> a
- Int
1) Bool
longestP (CGraph n e
graph, [[UINode]]
newLayers)
  | Bool
otherwise = (CGraph n e
graph, [[UINode]]
layers)
  where
    -- nodes that are at the center of attention
    priorityNodes :: [Int]
priorityNodes = forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> Vector Int
longestinfrequentPaths CGraph n e
graph [[UINode]]
revLayers
    revLayers :: [[UINode]]
revLayers = forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral) [[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]]
c =
      -- Debug.Trace.trace ("|l ") $ -- ++ show (layers, priorityNodes))
      forall a. [a] -> [a]
reverse (forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e -> Dir -> [[Int]] -> [Int] -> Bool -> [[Int]]
crossR CGraph n e
graph Dir
RightToLeft (forall a. [a] -> [a]
reverse (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral) [[UINode]]
layers)) (forall a. [a] -> [a]
reverse [Int]
priorityNodes) Bool
longestP)

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

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

    lu :: Int -> Maybe n
lu Int
n = forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) CGraph n e
g
    vertNum :: Int -> Maybe UINode
vertNum Int
n = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing forall n. NodeClass n => n -> Maybe UINode
Common.verticalNumber (Int -> Maybe n
lu Int
n)
crossR CGraph n e
_ Dir
_ [[Int]]
ls [Int]
ns Bool
_ = [[Int]]
ls

-- arrange vertical nodes directly below each other,
-- returns Nothing if there are no vertical nodes in this layer
lv :: EdgeClass e => CGraph n e -> [Int] -> [(Int, Bool)]
lv :: forall e n. EdgeClass e => CGraph n e -> [Int] -> [(Int, Bool)]
lv CGraph n e
_ [] = []
lv CGraph n e
g (Int
l : [Int]
ls) =
  -- Debug.Trace.trace ("vertConnected "++ show ((l,ls,ls \\ vertConnected),(goUp ps),l,(goDown cs))) $
  [(Int, Bool)]
vertConnected forall a. [a] -> [a] -> [a]
++ (forall e n. EdgeClass e => CGraph n e -> [Int] -> [(Int, Bool)]
lv CGraph n e
g ([Int]
ls forall a. Eq a => [a] -> [a] -> [a]
\\ (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Int, Bool)]
vertConnected)))
  where
    vertConnected :: [(Int, Bool)]
    vertConnected :: [(Int, Bool)]
vertConnected
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
up Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
down = [(Int
l, Bool
False)]
      | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. a -> (a, Bool)
tr ([Int]
up forall a. [a] -> [a] -> [a]
++ [Int
l] forall a. [a] -> [a] -> [a]
++ [Int]
down)
    tr :: a -> (a, Bool)
tr a
ll = (a
ll, Bool
True)
    up :: [Int]
up = [Int] -> [Int]
goUp [Int]
ps
    down :: [Int]
down = [Int] -> [Int]
goDown [Int]
cs
    ps :: [Int]
ps = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
    goUp :: [Int] -> [Int]
    goUp :: [Int] -> [Int]
goUp [Int]
n
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
n = []
      | Bool
otherwise = [Int] -> [Int]
goUp (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. [a] -> a
head [Int]
n))) forall a. [a] -> [a] -> [a]
++ [forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. [a] -> a
head [Int]
n)]

    cs :: [Int]
cs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
    goDown :: [Int] -> [Int]
    goDown :: [Int] -> [Int]
goDown [Int]
n
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
n = []
      | Bool
otherwise = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. [a] -> a
head [Int]
n)) forall a. a -> [a] -> [a]
: ([Int] -> [Int]
goDown (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. [a] -> a
head [Int]
n))))

-- type YNode = (YPos,Channel,UINode,IsDummy)
edgesEnum :: (NodeClass n, EdgeClass e, Show e) => IM.IntMap UINode -> IM.IntMap UINode -> CGraph n e -> Dir -> [UINode] -> [(YNode, YNode)]
edgesEnum :: 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 = forall a. [Maybe a] -> [a]
catMaybes [Maybe (YNode, YNode)]
edges
  where
    edges :: [Maybe (YNode, YNode)]
    edges :: [Maybe (YNode, YNode)]
edges = forall a b. (a -> b) -> [a] -> [b]
map (IntMap UINode
-> IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode)
edge IntMap UINode
en0 IntMap UINode
en1) (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)
      | forall a. Maybe a -> Bool
isNothing Maybe UINode
s Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing Maybe UINode
t = forall a. Maybe a
Nothing
      | Bool
otherwise =
        forall a. a -> Maybe a
Just
          ( (forall a. Int -> Maybe a -> a
myFromJust Int
517 Maybe UINode
s, Int
chanNr, UINode
src, forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
gr UINode
src),
            (forall a. Int -> Maybe a -> a
myFromJust Int
518 Maybe UINode
t, Int
0, UINode
tgt, forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
gr UINode
tgt)
          )
      where
        s :: Maybe UINode
s = forall a. Int -> IntMap a -> Maybe a
IM.lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
src) IntMap UINode
e0
        t :: Maybe UINode
t = forall a. Int -> IntMap a -> Maybe a
IM.lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
tgt) IntMap UINode
e1
        chanNr :: Int
chanNr
          | forall a. Maybe a -> Bool
isJust Maybe [e]
lu Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> Maybe a -> a
myFromJust Int
519 Maybe [e]
lu) = Int
0
          | forall a. Maybe a -> Bool
isJust Maybe [e]
lu = forall e. EdgeClass e => e -> Int
channelNrOut (forall a. Int -> [a] -> a
myhead Int
73 (forall a. Int -> Maybe a -> a
myFromJust Int
520 Maybe [e]
lu))
          | Bool
otherwise = Int
0
        lu :: Maybe [e]
lu = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (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 = forall a b. (a -> b) -> [a] -> [b]
map (UINode
n,) (forall a. Unbox a => Vector a -> [a]
VU.toList (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g UINode
n))
      | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (UINode
n,) (forall a. Unbox a => Vector a -> [a]
VU.toList (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
n))

-- type YPos = Int
-- type YNode = (YPos,Channel,UINode,IsDummy)

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

-- Assign every node in l1 a number thats the barycenter of its neighbours in l0, then sort.
-- If the node is marked as a vertical node with a number, this number has precedence in sorting
barycenter :: (NodeClass n, Show n, EdgeClass e, Show e) => CGraph n e -> Dir -> [Int] -> [Int] -> Int -> [Int]
barycenter :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e -> Dir -> [Int] -> [Int] -> Int -> [Int]
barycenter CGraph n e
g Dir
dir [Int]
l0 [Int]
l1 Int
_ =
  -- Debug.Trace.trace ("bary " ++ show (map bc l1, sortOn snd (map bc l1))) $
  forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> b
snd (forall a b. (a -> b) -> [a] -> [b]
map Int -> (Int, Double)
bc [Int]
l1))
  where
    bc :: Int -> (Int, Double)
    bc :: Int -> (Int, Double)
bc Int
node =
      -- Debug.Trace.trace ("bc" ++ show (dir, node, ps, cs, l0, l1, nodeWeight dir))
      (Int
node, Dir -> Double
nodeWeight Dir
dir)
      where
        lenCs :: Int
lenCs = forall a. Unbox a => Vector a -> Int
VU.length Vector Int
cs
        lenPs :: Int
lenPs = forall a. Unbox a => Vector a -> Int
VU.length Vector Int
ps
        cs :: Vector Int
cs = forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node))
        ps :: Vector Int
ps = forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node))
        nodeWeight :: Dir -> Double
        nodeWeight :: Dir -> Double
nodeWeight Dir
LeftToRight
          | forall a. Maybe a -> Bool
isJust Maybe UINode
vertNum -- Debug.Trace.trace ("bvert lr "++ show vertNum)
            =
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Int -> Maybe a -> a
myFromJust Int
521 Maybe UINode
vertNum)) forall a. Num a => a -> a -> a
+ (if forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
cs then Double
0 else (Int -> Double
subPos (forall a. Unbox a => Vector a -> a
VU.head Vector Int
cs)) forall a. Num a => a -> a -> a
* Double
10000)
          | Int
lenCs forall a. Eq a => a -> a -> Bool
== Int
0 =
            -- Debug.Trace.trace "bry -1"
            (-Double
1)
          --                | node == prioNode = -2
          | Bool
otherwise =
            -- Debug.Trace.trace ("bsum lr "++ show (VU.map xpos cs)) $
            ((forall a. (Unbox a, Num a) => Vector a -> a
VU.sum (forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map Int -> Double
xpos Vector Int
cs)) forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenCs)) forall a. Num a => a -> a -> a
+ (if forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
cs then Double
0 else (Int -> Double
subPos (forall a. Unbox a => Vector a -> a
VU.head Vector Int
cs)) forall a. Num a => a -> a -> a
* Double
10000)
        nodeWeight Dir
RightToLeft
          | forall a. Maybe a -> Bool
isJust Maybe UINode
vertNum =
            -- Debug.Trace.trace ("bvert rl "++ show vertNum)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Int -> Maybe a -> a
myFromJust Int
522 Maybe UINode
vertNum)) forall a. Num a => a -> a -> a
+ (if forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
cs then Double
0 else (Int -> Double
subPos (forall a. Unbox a => Vector a -> a
VU.head Vector Int
cs)) forall a. Num a => a -> a -> a
* Double
10000)
          | Int
lenPs forall a. Eq a => a -> a -> Bool
== Int
0 -- Debug.Trace.trace "bry -1"
            =
            (-Double
1)
          --                | node == prioNode = -2
          | Bool
otherwise -- Debug.Trace.trace ("bsum rl "++ show (VU.map xpos ps)) $
            =
            ((forall a. (Unbox a, Num a) => Vector a -> a
VU.sum (forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map Int -> Double
xpos Vector Int
ps)) forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenPs)) forall a. Num a => a -> a -> a
+ (if forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
cs then Double
0 else (Int -> Double
subPos (forall a. Unbox a => Vector a -> a
VU.head Vector Int
cs)) forall a. Num a => a -> a -> a
* Double
10000)

        lu :: Maybe n
lu = forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node) CGraph n e
g
        vertNum :: Maybe UINode
vertNum = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing forall n. NodeClass n => n -> Maybe UINode
Common.verticalNumber Maybe n
lu
        xpos :: Int -> Double
        xpos :: Int -> Double
xpos Int
c =
          -- Debug.Trace.trace (show (c, l0,maybe 0 fromIntegral (elemIndex c l0), subPos c)) $
          (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
c [Int]
l0))

        subPos :: Int -> Double
        subPos :: Int -> Double
subPos Int
c =
          -- Debug.Trace.trace (show channel ++ " : " ++ show channels) $
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
channel) forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
channels)
          where
            channel :: Int
channel = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall e. EdgeClass e => e -> Int
channelNrOut Maybe e
edgeLabel
            channels :: Int
channels = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 forall {n}. NodeClass n => n -> Int
nrTypes (forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c) CGraph n e
g)
            nrTypes :: n -> Int
nrTypes n
x
              | forall n. NodeClass n => n -> Bool
isSubLabel n
x = forall {n}. NodeClass n => n -> Int
subLabels n
x
              | Bool
otherwise = Int
1
            edgeLabel :: Maybe e
edgeLabel
              | forall a. Maybe a -> Bool
isNothing (forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode, UINode)
dEdge CGraph n e
g) = forall a. Maybe a
Nothing
              | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> Maybe a -> a
myFromJust Int
523 (forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode, UINode)
dEdge CGraph n e
g)) = forall a. Maybe a
Nothing
              | Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> [a] -> a
myhead Int
74) (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 = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c)

-- Assign every node in l0 a number thats the median of its neighbours in l1, then sort
median :: EdgeClass e => CGraph n e -> [Int] -> [Int] -> [Int]
median :: forall e n. EdgeClass e => CGraph n e -> [Int] -> [Int] -> [Int]
median CGraph n e
g [Int]
l0 [Int]
l1 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Vector Int
m forall a. Unbox a => Vector a -> Int -> a
VU.! (Int
len forall a. Integral a => a -> a -> a
`div` Int
2))
      where
        len :: Int
len = forall a. Unbox a => Vector a -> Int
VU.length Vector Int
cs
        cs :: Vector Int
        cs :: Vector Int
cs =
          forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map
            (\UINode
x -> forall a. a -> Maybe a -> a
fromMaybe Int
0 (forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
x) [Int]
l1))
            (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node))
        m :: Vector Int
m = forall a.
Unbox a =>
(forall s. MVector s a -> ST s ()) -> Vector a -> Vector a
VU.modify 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 a.
Unbox a =>
(forall s. MVector s a -> ST s ()) -> Vector a -> Vector a
VU.modify (forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m ()
I.sortBy 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 forall a. Ord a => a -> a -> Bool
> a
e1y0)
            Bool -> Bool -> Bool
|| (a
e0y0 forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 forall a. Ord a => a -> a -> Bool
> a
e1n0)
            Bool -> Bool -> Bool
|| (a
e0y0 forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 forall a. Eq a => a -> a -> Bool
== a
e1n0 Bool -> Bool -> Bool
&& a
e0y1 forall a. Ord a => a -> a -> Bool
> a
e1y1)
            Bool -> Bool -> Bool
|| (a
e0y0 forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 forall a. Eq a => a -> a -> Bool
== a
e1n0 Bool -> Bool -> Bool
&& a
e0y1 forall a. Eq a => a -> a -> Bool
== a
e1y1 Bool -> Bool -> Bool
&& a
e0n1 forall a. Ord a => a -> a -> Bool
> a
e1n1) =
          Ordering
GT
        | a
e0y0 forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 forall a. Eq a => a -> a -> Bool
== a
e1n0 Bool -> Bool -> Bool
&& a
e0y1 forall a. Eq a => a -> a -> Bool
== a
e1y1 Bool -> Bool -> Bool
&& a
e0n1 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 =
  forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
    [ if (Vector Int
xs forall a. Unbox a => Vector a -> Int -> a
VU.! Int
i) forall a. Ord a => a -> a -> Bool
> (Vector Int
xs forall a. Unbox a => Vector a -> Int -> a
VU.! Int
j) then Int
1 else Int
0 | Int
i <- [Int
0 .. ((forall a. Unbox a => Vector a -> Int
VU.length Vector Int
xs) forall a. Num a => a -> a -> a
- Int
1)], Int
j <- [Int
i .. ((forall a. Unbox a => Vector a -> Int
VU.length Vector Int
xs) forall a. Num a => a -> a -> a
- Int
1)]
    ]

--  where l = VU.length xs

-- Modified merge sort for counting of edge crossings
-- which is the same as counting inversions (see)
-- http://www.geeksforgeeks.org/counting-inversions/

merge :: ([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge :: ([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 forall a. Ord a => a -> a -> Bool
<= Int
y = (Int
x forall a. a -> [a] -> [a]
: (forall a b. (a, b) -> a
fst (([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge ([Int]
xt, Int
inv0) ([Int]
ys, Int
inv1))), Int
inv0 forall a. Num a => a -> a -> a
+ Int
inv1)
  | Bool
otherwise = (Int
y forall a. a -> [a] -> [a]
: (forall a b. (a, b) -> a
fst (([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge ([Int]
xs, Int
inv0) ([Int]
yt, Int
inv1))), Int
inv0 forall a. Num a => a -> a -> a
+ Int
inv1 forall a. Num a => a -> a -> a
+ 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) = forall a. [a] -> ([a], [a])
split [a]
zs in (a
x forall a. a -> [a] -> [a]
: [a]
xs, a
y forall a. a -> [a] -> [a]
: [a]
ys)
split [a
x] = ([a
x], [])
split [] = ([], [])

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) = 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))

-- https://hackage.haskell.org/package/splaytree
-- https://hackage.haskell.org/package/TreeStructures-0.0.1/docs/Data-Tree-Splay.html

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

------------------------------------------------------------------------------------------------------------------------------

-- | To be able to jump vertically between nodes in an interactive ui
getColumns :: EdgeClass e => CGraphL n e -> (Map X [UINode], Map.Map Int [Column])
getColumns :: forall e n.
EdgeClass e =>
CGraphL n e -> (Map Int [UINode], Map Int [Column])
getColumns (Graph n [e]
gr, Map UINode (Int, Int)
m) = (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [Column]
cols, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ([Column] -> [[Column]]
divideTables [Column]
cols)))
  where
    cols :: [Column]
cols =
      forall a b. (a -> b) -> [a] -> [b]
map
        [UINode] -> Column
tupleWithX
        ( ( (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy UINode -> UINode -> Ordering
sorty))
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy UINode -> UINode -> Bool
groupx)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy UINode -> UINode -> Ordering
sortx)
          )
            (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall {a} {el}. Graph a el -> [Int]
Graph.nodes Graph n [e]
gr))
        )
    tupleWithX :: [UINode] -> (X, [UINode])
    tupleWithX :: [UINode] -> Column
tupleWithX [UINode]
ls = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. Int -> [a] -> a
myhead Int
504 [UINode]
ls) Map UINode (Int, Int)
m), [UINode]
ls)
    groupx :: UINode -> UINode -> Bool
groupx UINode
n0 UINode
n1 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Map UINode (Int, Int)
m) forall a. Eq a => a -> a -> Bool
== forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Map UINode (Int, Int)
m)
    sortx :: UINode -> UINode -> Ordering
sortx UINode
n0 UINode
n1 = forall a. Ord a => a -> a -> Ordering
compare (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Map UINode (Int, Int)
m)) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Map UINode (Int, Int)
m))
    sorty :: UINode -> UINode -> Ordering
sorty UINode
n0 UINode
n1 = forall a. Ord a => a -> a -> Ordering
compare (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Map UINode (Int, Int)
m)) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Map UINode (Int, Int)
m))

    -- There can be several graphs on the screen that are connected with separating edges
    divideTables :: [Column] -> [[Column]]
    divideTables :: [Column] -> [[Column]]
divideTables [] = []
    divideTables [Column]
layers = [Column]
layersWithoutSep forall a. a -> [a] -> [a]
: [Column] -> [[Column]]
divideTables [Column]
rest
      where
        ([Column]
layersWithoutSep, [Column]
rest) = ([Column], [Column]) -> ([Column], [Column])
sumLayers ([], [Column]
layers)
        sumLayers :: ([Column], [Column]) -> ([Column], [Column])
        sumLayers :: ([Column], [Column]) -> ([Column], [Column])
sumLayers ([Column]
s, []) = ([Column]
s, [])
        sumLayers ([Column]
s, Column
l : [Column]
ls)
          | [UINode] -> Bool
containsSeparatingEdge (forall a b. (a, b) -> b
snd Column
l) = ([Column]
s forall a. [a] -> [a] -> [a]
++ [Column
l], [Column]
ls)
          | Bool
otherwise = ([Column], [Column]) -> ([Column], [Column])
sumLayers ([Column]
s forall a. [a] -> [a] -> [a]
++ [Column
l], [Column]
ls)
        containsSeparatingEdge :: [UINode] -> Bool
containsSeparatingEdge [UINode]
ns = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UINode -> Bool
cs [UINode]
ns
        cs :: UINode -> Bool
cs UINode
n = forall a. Unbox a => Vector a -> Int
VU.length (forall e n. EdgeClass e => Graph n [e] -> UINode -> Vector UINode
childrenSeparating Graph n [e]
gr UINode
n) forall a. Ord a => a -> a -> Bool
> Int
0

-- | To be able to jump horizontally between nodes in an interactive ui
getRows :: CGraphL n e -> Map Y [UINode]
getRows :: forall n e. CGraphL n e -> Map Int [UINode]
getRows (Graph n [e]
gr, Map UINode (Int, Int)
m) =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map
      [UINode] -> Column
tupleWithY
      ( ( (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy UINode -> UINode -> Ordering
sortx))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy UINode -> UINode -> Bool
groupy)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy UINode -> UINode -> Ordering
sorty)
        )
          (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall {a} {el}. Graph a el -> [Int]
Graph.nodes Graph n [e]
gr))
      )
  where
    tupleWithY :: [UINode] -> (Y, [UINode])
    tupleWithY :: [UINode] -> Column
tupleWithY [UINode]
ls = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. Int -> [a] -> a
myhead Int
504 [UINode]
ls) Map UINode (Int, Int)
m), [UINode]
ls)
    groupy :: UINode -> UINode -> Bool
groupy UINode
n0 UINode
n1 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Map UINode (Int, Int)
m) forall a. Eq a => a -> a -> Bool
== forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Map UINode (Int, Int)
m)
    sortx :: UINode -> UINode -> Ordering
sortx UINode
n0 UINode
n1 = forall a. Ord a => a -> a -> Ordering
compare (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Map UINode (Int, Int)
m)) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Map UINode (Int, Int)
m))
    sorty :: UINode -> UINode -> Ordering
sorty UINode
n0 UINode
n1 = forall a. Ord a => a -> a -> Ordering
compare (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Map UINode (Int, Int)
m)) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Map UINode (Int, Int)
m))