{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

{- |
Description: Binary tree layout; compact
Copyright: Copyright (C) 2021 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P66" of Ninety-Nine Haskell "Problems".
-}
module Solutions.P66 (layoutCompact) where

import           Problems.BinaryTrees

-- | Lay out a binary tree compactly.
layoutCompact :: Tree a -> Tree (a, (Int, Int))
layoutCompact :: forall a. Tree a -> Tree (a, (Int, Int))
layoutCompact Tree a
t = Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
forall a.
Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
place Tree (a, Int, Bounds)
t' (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tree (a, Int, Bounds) -> Int
forall a. Tree (a, Int, Bounds) -> Int
leftMost Tree (a, Int, Bounds)
t') Int
1
  where t' :: Tree (a, Int, Bounds)
t' = Tree a -> Tree (a, Int, Bounds)
forall a. Tree a -> Tree (a, Int, Bounds)
layout Tree a
t

-- | Horizontal position of node, relative to parent.
type Position = Int

-- | Leftmost and rightmost positions in subtree, relative to parent.
type Bounds = [(Int,Int)]

layout :: Tree a -> Tree (a, Position, Bounds)
layout :: forall a. Tree a -> Tree (a, Int, Bounds)
layout Tree a
Empty          = Tree (a, Int, Bounds)
forall a. Tree a
Empty
layout (Branch a
x Tree a
Empty Tree a
Empty) = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
x, Int
0, []) Tree (a, Int, Bounds)
forall a. Tree a
Empty Tree (a, Int, Bounds)
forall a. Tree a
Empty

-- Place left subtree one unit to the left.
layout (Branch a
x Tree a
l Tree a
Empty) = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a, Int, Bounds)
val Tree (a, Int, Bounds)
l' Tree (a, Int, Bounds)
forall a. Tree a
Empty
  where val :: (a, Int, Bounds)
val = (a
x, Int
0, (-Int
1,-Int
1) (Int, Int) -> Bounds -> Bounds
forall a. a -> [a] -> [a]
: Bounds -> Int -> Bounds
shiftBounds Bounds
ps' (-Int
1))
        l' :: Tree (a, Int, Bounds)
l' = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
x', -Int
1, Bounds
ps') Tree (a, Int, Bounds)
ll' Tree (a, Int, Bounds)
lr'
        (Branch (a
x', Int
_, Bounds
ps') Tree (a, Int, Bounds)
ll' Tree (a, Int, Bounds)
lr') = Tree a -> Tree (a, Int, Bounds)
forall a. Tree a -> Tree (a, Int, Bounds)
layout Tree a
l

-- Place right subtree one unit to the left.
layout (Branch a
x Tree a
Empty Tree a
r) = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a, Int, Bounds)
val Tree (a, Int, Bounds)
forall a. Tree a
Empty Tree (a, Int, Bounds)
r'
  where val :: (a, Int, Bounds)
val = (a
x, Int
0, (Int
1,Int
1) (Int, Int) -> Bounds -> Bounds
forall a. a -> [a] -> [a]
: Bounds -> Int -> Bounds
shiftBounds Bounds
ps' Int
1)
        r' :: Tree (a, Int, Bounds)
r' = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
x', Int
1, Bounds
ps') Tree (a, Int, Bounds)
rl' Tree (a, Int, Bounds)
rr'
        (Branch (a
x', Int
_, Bounds
ps') Tree (a, Int, Bounds)
rl' Tree (a, Int, Bounds)
rr') = Tree a -> Tree (a, Int, Bounds)
forall a. Tree a -> Tree (a, Int, Bounds)
layout Tree a
r

layout (Branch a
x Tree a
l Tree a
r) = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
x, Int
0, Bounds
ps) Tree (a, Int, Bounds)
l' Tree (a, Int, Bounds)
r'
  where
    -- Find the leftmost and rightmost bounds for each subtree.
    lps' :: Bounds
lps' = Bounds -> Int -> Bounds
shiftBounds Bounds
lps (-Int
d)
    rps' :: Bounds
rps' = Bounds -> Int -> Bounds
shiftBounds Bounds
rps Int
d
    -- Move them far enough apart that the rightmost nodes in the left subtree
    -- do not overlap with the leftmost nodes in the right subtree.
    d :: Int
d = Bounds -> Bounds -> Int
safeDistance Bounds
lps Bounds
rps
    -- Get leftmost and rightmost bounds for this tree from those of the subtrees.
    ps :: Bounds
ps = (-Int
d,Int
d) (Int, Int) -> Bounds -> Bounds
forall a. a -> [a] -> [a]
: Bounds -> Bounds -> Bounds
mergeBounds Bounds
lps' Bounds
rps'
    l' :: Tree (a, Int, Bounds)
l' = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
lx, -Int
d, Bounds
lps) Tree (a, Int, Bounds)
ll Tree (a, Int, Bounds)
lr
    r' :: Tree (a, Int, Bounds)
r' = (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
-> Tree (a, Int, Bounds)
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
rx, Int
d, Bounds
rps) Tree (a, Int, Bounds)
rl Tree (a, Int, Bounds)
rr
    (Branch (a
lx, Int
_, Bounds
lps) Tree (a, Int, Bounds)
ll Tree (a, Int, Bounds)
lr) = Tree a -> Tree (a, Int, Bounds)
forall a. Tree a -> Tree (a, Int, Bounds)
layout Tree a
l
    (Branch (a
rx, Int
_, Bounds
rps) Tree (a, Int, Bounds)
rl Tree (a, Int, Bounds)
rr) = Tree a -> Tree (a, Int, Bounds)
forall a. Tree a -> Tree (a, Int, Bounds)
layout Tree a
r

-- Turn relative positions between parent and child nodes into absolute positions.
place :: Tree (a, Position, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
place :: forall a.
Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
place Tree (a, Int, Bounds)
Empty Int
_ Int
_ = Tree (a, (Int, Int))
forall a. Tree a
Empty
place (Branch (a
x, Int
p, Bounds
_) Tree (a, Int, Bounds)
l Tree (a, Int, Bounds)
r) Int
pos Int
depth = (a, (Int, Int))
-> Tree (a, (Int, Int))
-> Tree (a, (Int, Int))
-> Tree (a, (Int, Int))
forall a. a -> Tree a -> Tree a -> Tree a
Branch (a
x, (Int
p', Int
depth)) Tree (a, (Int, Int))
l' Tree (a, (Int, Int))
r'
  where p' :: Int
p' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p
        l' :: Tree (a, (Int, Int))
l' = Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
forall a.
Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
place Tree (a, Int, Bounds)
l Int
p' (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        r' :: Tree (a, (Int, Int))
r' = Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
forall a.
Tree (a, Int, Bounds) -> Int -> Int -> Tree (a, (Int, Int))
place Tree (a, Int, Bounds)
r Int
p' (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-- Find the leftmost position in the tree.
leftMost :: Tree (a, Position, Bounds) -> Int
leftMost :: forall a. Tree (a, Int, Bounds) -> Int
leftMost Tree (a, Int, Bounds)
Empty                   = Int
0
leftMost (Branch (a
_, Int
p, Bounds
ps) Tree (a, Int, Bounds)
_ Tree (a, Int, Bounds)
_) = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((Int, Int) -> Int) -> Bounds -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst Bounds
ps

shiftBounds :: Bounds -> Int -> Bounds
shiftBounds :: Bounds -> Int -> Bounds
shiftBounds Bounds
ps Int
d = ((Int, Int) -> (Int, Int)) -> Bounds -> Bounds
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
l,Int
r) -> (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d,Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d)) Bounds
ps

mergeBounds :: Bounds -> Bounds -> Bounds
mergeBounds :: Bounds -> Bounds -> Bounds
mergeBounds [] []                      = []
mergeBounds [] Bounds
ps                      = Bounds
ps
mergeBounds Bounds
ps []                      = Bounds
ps
mergeBounds ((Int
l,Int
_) : Bounds
ps) ((Int
_,Int
r) : Bounds
ps') = (Int
l,Int
r) (Int, Int) -> Bounds -> Bounds
forall a. a -> [a] -> [a]
: Bounds -> Bounds -> Bounds
mergeBounds Bounds
ps Bounds
ps'

safeDistance :: [(Int,Int)] -> [(Int,Int)] -> Int
safeDistance :: Bounds -> Bounds -> Int
safeDistance Bounds
ps Bounds
ps' = Int -> Int
find Int
1
  where find :: Int -> Int
find Int
d | Bounds -> Bounds -> Int -> Bool
isSafe Bounds
ps Bounds
ps' Int
d = Int
d
               | Bool
otherwise       = Int -> Int
find (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

isSafe :: [(Int,Int)]  -- Leftmost and rightmost positions for first subtree.
       -> [(Int,Int)]  -- Leftmost and rightmost positions for second subtree.
       -> Int          -- Horizontal distance between parent and child to try.
       -> Bool         -- If distance is enough to prevent overlaps.
isSafe :: Bounds -> Bounds -> Int -> Bool
isSafe [] Bounds
_ Int
_                          = Bool
True
isSafe Bounds
_ [] Int
_                          = Bool
True
isSafe ((Int
_,Int
r) : Bounds
ps) ((Int
l,Int
_) : Bounds
ps') Int
dist = (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dist) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dist) Bool -> Bool -> Bool
&& Bounds -> Bounds -> Int -> Bool
isSafe Bounds
ps Bounds
ps' Int
dist