{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Graph.SubGraphWindows (subgraphWindows, getColumns, getRows) where
import qualified Data.IntMap as I
import Data.List (groupBy, sortBy, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Vector.Unboxed as VU
import Debug.Trace ( trace )
import Graph.CommonGraph
( CGraph,
CGraphL,
Column,
LayerFeatures (..),
NodeClass (dummyNode, isArgLabel, updateLayer),
EdgeClass,
UINode,
bb,
childrenSeparating,
layer,
lb,
lbb,
ltb,
mid,
myhead,
nestingFeatures,
parentsVertical,
rb,
rbb,
rtb,
tb,
)
import Graph.GraphDrawing (getColumns, getRows)
import Graph.IntMap (nodes)
import qualified Graph.IntMap as Graph
data Span = SpanLeftBorder | SpanMiddle | SpanRightBorder | SpanOutside deriving (Show)
data SpanInOut = Outside | Inside
type Layer = Int -- the nesting of the window:
-- 0 -> dummy node
-- 1 -> not part of a window
-- 2 -> first window layer
type X = Int
type Y = Int
type Min = Int
type Max = Int
subgraphWindows :: (EdgeClass e, NodeClass n, Show n, VU.Unbox UINode) => CGraphL n e -> CGraphL n e
subgraphWindows (graph, pos)
| null ns = (graph, pos)
| otherwise -- Debug.Trace.trace ("subgraphWindows "++ show (graph,pos,newGraph,normalisedPos) ++"\n") -- ++ -- show newGraph ++"\n"++
-- show pos ++"\n"++ show (rows,zRows,spans zRows) ++"\n"++ show (fst columns,zColumns, spans zColumns)) $
=
(newGraph, normalisedPos)
where
newGraph =
Graph.mapNodeWithKey
changeNode
filledGraph
changeNode :: NodeClass n => I.Key -> n -> n
changeNode n node = changeLayer nf n node
where nf = nestingFeatures node
changeLayer :: NodeClass n => Maybe LayerFeatures -> I.Key -> n -> n
changeLayer Nothing n node
| isArgLabel node = updateLayer (changeStyle l defaultFeatures) node
| otherwise = updateLayer (changeStyle l defaultFeatures) node
where
l = highestLayer xy (spans zRows) (spans zColumns)
xy = fromMaybe (0, 0) (Map.lookup (fromIntegral n) normalisedPos)
_xy2 = fromMaybe (0, 0) (Map.lookup (fromIntegral root) normalisedPos)
root = rootOf graph (fromIntegral n)
changeLayer nestingFeats n node
| isArgLabel node = updateLayer (changeStyle l (Just ((fromJust nestingFeats) {layer = fst l}))) node
| otherwise = updateLayer (changeStyle l nestingFeats) node
where
l = highestLayer xy (spans zRows) (spans zColumns)
xy = fromMaybe (0, 0) (Map.lookup (fromIntegral n) normalisedPos)
rootOf :: EdgeClass e => CGraph n e -> UINode -> UINode
rootOf gr node
| VU.null psVert = node
| otherwise = rootOf gr (VU.head psVert)
where
psVert = parentsVertical gr node
defaultFeatures = Just (LayerFeatures 0 Nothing)
changeStyle :: (Int, (Span, Span)) -> Maybe LayerFeatures -> Maybe LayerFeatures
changeStyle (n, (SpanLeftBorder, SpanLeftBorder)) style = maybeReplace style n lbb -- LeftBottomBorder
changeStyle (n, (SpanLeftBorder, SpanMiddle)) style -- n >= 2 = maybeReplace style n mid
=
maybeReplace style n bb -- BottomBorder
changeStyle (n, (SpanLeftBorder, SpanRightBorder)) style -- n >= 2 = maybeReplace style n mid
=
maybeReplace style n rbb -- RightBottomBorder
changeStyle (n, (SpanMiddle, SpanLeftBorder)) style = maybeReplace style n lb -- LeftBorder
changeStyle (n, (SpanMiddle, SpanMiddle)) style = maybeReplace style n mid
changeStyle (n, (SpanMiddle, SpanRightBorder)) style -- n >= 2 = maybeReplace style n mid
=
maybeReplace style n rb -- RightBorder
changeStyle (n, (SpanRightBorder, SpanLeftBorder)) style -- n >= 4 = maybeReplace style n mid
=
maybeReplace style n ltb -- LeftTopBorder
changeStyle (n, (SpanRightBorder, SpanMiddle)) style -- n >= 4 = maybeReplace style n mid
=
maybeReplace style n tb -- TopBorder
changeStyle (n, (SpanRightBorder, SpanRightBorder)) style -- n >= 4 = maybeReplace style n mid
=
maybeReplace style n rtb -- RightTopBorder
changeStyle (_, _) style = style
maybeReplace :: Maybe LayerFeatures -> Int -> (Int -> Maybe LayerFeatures) -> Maybe LayerFeatures
maybeReplace (Just (LayerFeatures 0 _)) n lf = lf n
maybeReplace (Just (LayerFeatures x _)) _ lf = lf x
maybeReplace _ n lf = Debug.Trace.trace "_" lf n
filledGraph = Graph.insertNodes (map fr newNodes) graph
fr (n, nl) = (fromIntegral n, nl)
normalisedPos = Map.map (\(x, y) -> (x - minX, y - minY)) (Map.union pos newPos)
newNodes = zipWith dNode [(m + 1) ..] holes
newPos = Map.fromList (zip (map fromIntegral [(m + 1) ..]) holes)
dNode n _ = (n, dummyNode 1)
m = maximum (nodes graph)
holes :: [(Int, Int)]
holes = [(x, y) | x <- [minX .. maxX], y <- [minY .. maxY]] \\ nodePositions
nodePositions = Map.elems pos
ns = I.toList (Graph.nodeLabels graph)
minX = minimum (map fst nodePositions)
minY = minimum (map snd nodePositions)
maxX = maximum (map fst nodePositions)
maxY = maximum (map snd nodePositions)
rows :: Map Y [UINode]
rows = getRows (filledGraph, normalisedPos)
columns = getColumns (filledGraph, normalisedPos)
maxZCoord = maximum $ map (\(_, nl) -> zOfNode nl) ns
zOfNode nl = maybe 0 layer (nestingFeatures nl)
zLayers :: [(X, [UINode])] -> [(Layer, [(X, [Layer])])]
zLayers xs = map getLayer (reverse [1 .. maxZCoord])
where
getLayer l = (l, map zOfNodes xs)
where
zOfNodes (x, ns1) = (x, map zLayer ns1)
zLayer n
| isJust lu && zOfNode (fromJust lu) >= l = l
| otherwise = 0
where
lu = Graph.lookupNode n graph
zRows :: [(Layer, [(X, [Layer])])]
zRows = zLayers (Map.toList rows)
zColumns = zLayers (Map.toList (fst columns))
spans :: [(Layer, [(X, [Layer])])] -> Map Layer (Map X [(Min, Max)])
spans ls = Map.fromList (map zSpans ls)
where
zSpans (z, rs) = (z, Map.fromList (map rowsColums rs))
where
rowsColums (x, layers) = (x, minMax layers 0 0 Outside)
minMax :: [Layer] -> Int -> Int -> SpanInOut -> [(Min, Max)]
minMax [] start i Inside = [(start, i - 1)]
minMax [] _ _ _ = []
minMax (l : layers) start i Outside
| l == z = minMax layers i (i + 1) Inside
| otherwise = minMax layers start (i + 1) Outside
minMax (l : layers) start i Inside
| l == z = minMax layers start (i + 1) Inside
| otherwise = (start, i - 1) : minMax layers start (i + 1) Outside
highestLayer ::
(X, Y) ->
Map Layer (Map X [(Min, Max)]) ->
Map Layer (Map X [(Min, Max)]) ->
(Layer, (Span, Span))
highestLayer (x, y) hrows cols = findFirstWindow maxZCoord
where
findFirstWindow 0 = (0, (SpanOutside, SpanOutside))
findFirstWindow z
| found c r = (z, (c, r))
| otherwise = findFirstWindow (z - 1)
where
c = maybe SpanOutside (overlappedByNeighbouringSpans (x, y) True) (Map.lookup z cols)
r = maybe SpanOutside (overlappedByNeighbouringSpans (x, y) False) (Map.lookup z hrows)
found SpanOutside _ = False
found _ SpanOutside = False
found _ _ = True
-- Is there at least one neighboring row/column that includes the X/Y coordinate in its span
overlappedByNeighbouringSpans :: (X, Y) -> Bool -> Map X [(Min, Max)] -> Span
overlappedByNeighbouringSpans (x, y) isColumn nspans
| isColumn = maybe SpanOutside spanPositionColumn (minmax (goLeft x ++ goRight (x + 1)))
| otherwise = maybe SpanOutside spanPositionRow (minmax (goLeft y ++ goRight (y + 1)))
where
spanPositionColumn (smin, smax)
| y == smin = SpanRightBorder
| y == smax = SpanLeftBorder
| y > smin && y < smax = SpanMiddle
| otherwise = SpanOutside
spanPositionRow (smin, smax)
| x == smin = SpanLeftBorder
| x == smax = SpanRightBorder
| x > smin && x < smax = SpanMiddle
| otherwise = SpanOutside
minmax xs
| null xs = Nothing
| otherwise = Just (minimum (map fst xs), maximum (map snd xs))
goLeft p
| null mm = mm
| otherwise = mm ++ goLeft (p - 1)
where
mm = fromMaybe [] (Map.lookup p nspans)
goRight p
| null mm = mm
| otherwise = mm ++ goRight (p + 1)
where
mm = fromMaybe [] (Map.lookup p nspans)