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