{-# LANGUAGE DeriveFoldable            #-}
{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE DeriveTraversable         #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeFamilies              #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Layout.Tree
-- Copyright   :  (c) 2011 Brent Yorgey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  byorgey@cis.upenn.edu
--
-- A collection of methods for laying out various kinds of trees.
-- This module is still experimental, and more layout methods will
-- probably be added over time.
--
-- Laying out a rose tree using a symmetric layout:
--
-- > import Data.Tree
-- > import Diagrams.TwoD.Layout.Tree
-- >
-- > t1 = Node 'A' [Node 'B' (map lf "CDE"), Node 'F' [Node 'G' (map lf "HIJKLM"), Node 'N' (map lf "OPQR")]]
-- >   where lf x = Node x []
-- >
-- > exampleSymmTree =
-- >   renderTree ((<> circle 1 # fc white) . text . (:[]))
-- >              (~~)
-- >              (symmLayout' (with & slHSep .~ 4 & slVSep .~ 4) t1)
-- >   # centerXY # pad 1.1
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Tree_exampleSymmTree.svg#diagram=exampleSymmTree&width=300>>
--
-- Laying out a rose tree of diagrams, with spacing automatically
-- adjusted for the size of the diagrams:
--
-- > import Data.Tree
-- > import Data.Maybe (fromMaybe)
-- > import Diagrams.TwoD.Layout.Tree
-- >
-- > tD = Node (rect 1 3)
-- >        [ Node (circle 0.2) []
-- >        , Node (hcat . replicate 3 $ circle 1) []
-- >        , Node (eqTriangle 5) []
-- >        ]
-- >
-- > exampleSymmTreeWithDs =
-- >   renderTree id (~~)
-- >   (symmLayout' (with & slWidth  .~ fromMaybe (0,0) . extentX
-- >                      & slHeight .~ fromMaybe (0,0) . extentY)
-- >      tD)
-- >   # centerXY # pad 1.1
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Tree_exampleSymmTreeWithDs.svg#diagram=exampleSymmTreeWithDs&width=300>>
--
-- Using a variant symmetric layout algorithm specifically for binary trees:
--
-- > import Diagrams.TwoD.Layout.Tree
-- > import Diagrams.Prelude hiding (Empty)
-- >
-- > drawT = maybe mempty (renderTree (const (circle 0.05 # fc black)) (~~))
-- >       . symmLayoutBin' (with & slVSep .~ 0.5)
-- >
-- > tree500 = drawT t # centerXY # pad 1.1
-- >   where t = genTree 500 0.05
-- >         -- genTree 500 0.05 randomly generates trees of size 500 +/- 5%,
-- >         -- definition not shown
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Tree_tree500.svg#diagram=tree500&width=400>>
--
-- Using force-based layout on a binary tree:
--
-- > {-# LANGUAGE NoMonomorphismRestriction #-}
-- > import Diagrams.Prelude hiding (Empty)
-- > import Diagrams.TwoD.Layout.Tree
-- >
-- > gent 0 = Empty
-- > gent n = BNode n (gent (n-1)) (gent (n-1))
-- >
-- > Just t' = uniqueXLayout 1 1 (gent 4)
-- >
-- > fblEx = renderTree (\n -> (text (show n) # fontSizeL 0.5
-- >                             <> circle 0.3 # fc white))
-- >             (~~)
-- >             (forceLayoutTree t')
-- >         # centerXY # pad 1.1
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Tree_fblEx.svg#diagram=fblEx&width=300>>
--
-- Using a radial layout:
--
-- > import Diagrams.Prelude
-- > import Diagrams.TwoD.Layout.Tree
-- > import Data.Tree
-- >
-- > t = Node 'A' [Node 'B' (map lf "CDE"), Node 'F' [Node 'G' (map lf "HIJKLM"), Node 'N' (map lf "OPQRS")], Node 'T' (map lf "UVWXYZ")]
-- >   where lf x = Node x []
-- >
-- > radialEx =
-- >    renderTree (\n -> (text (show n) # fontSizeG 0.5
-- >                             <> circle 0.5 # fc white))
-- >              (~~) (radialLayout t)
-- >    # centerXY # pad 1.1
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Tree_radialEx.svg#diagram=radialEx&width=300>>

module Diagrams.TwoD.Layout.Tree
       ( -- * Binary trees
         -- $BTree

         BTree(..)
       , leaf

         -- * Layout algorithms

         -- ** Unique-x layout

       , uniqueXLayout

         -- ** Radial layout

       , radialLayout

         -- ** Symmetric layout

         -- $symmetric
       , symmLayout
       , symmLayout'
       , symmLayoutBin
       , symmLayoutBin'
       , SymmLayoutOpts(..), slHSep, slVSep, slWidth, slHeight

         -- ** Force-directed layout
         -- $forcedirected

       , forceLayoutTree
       , forceLayoutTree'
       , ForceLayoutTreeOpts(..), forceLayoutOpts, edgeLen, springK, staticK

       , treeToEnsemble
       , label
       , reconstruct

         -- * Rendering

       , renderTree
       , renderTree'

       ) where

import           Physics.ForceLayout

import           Control.Arrow       (first, second, (&&&), (***))
import           Control.Monad.State

import           Data.Default
import qualified Data.Foldable       as F
import           Data.Function       (on)
import           Data.List           (mapAccumL)
import qualified Data.Map            as M
import           Data.Maybe
import qualified Data.Traversable    as T
import           Data.Tree

import           Control.Lens        (makeLenses, view, (+=), (-=), (^.))
import           Diagrams
import           Linear              ((*^))
import           Linear.Affine

------------------------------------------------------------
--  Binary trees
------------------------------------------------------------

-- $BTree
-- There is a standard type of rose trees ('Tree') defined in the
-- @containers@ package, but there is no standard type for binary
-- trees, so we define one here.  Note, if you want to draw binary
-- trees with data of type @a@ at the leaves, you can use something
-- like @BTree (Maybe a)@ with @Nothing@ at internal nodes;
-- 'renderTree' lets you specify how to draw each node.

-- | Binary trees with data at internal nodes.
data BTree a = Empty | BNode a (BTree a) (BTree a)
  deriving (BTree a -> BTree a -> Bool
(BTree a -> BTree a -> Bool)
-> (BTree a -> BTree a -> Bool) -> Eq (BTree a)
forall a. Eq a => BTree a -> BTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => BTree a -> BTree a -> Bool
== :: BTree a -> BTree a -> Bool
$c/= :: forall a. Eq a => BTree a -> BTree a -> Bool
/= :: BTree a -> BTree a -> Bool
Eq, Eq (BTree a)
Eq (BTree a) =>
(BTree a -> BTree a -> Ordering)
-> (BTree a -> BTree a -> Bool)
-> (BTree a -> BTree a -> Bool)
-> (BTree a -> BTree a -> Bool)
-> (BTree a -> BTree a -> Bool)
-> (BTree a -> BTree a -> BTree a)
-> (BTree a -> BTree a -> BTree a)
-> Ord (BTree a)
BTree a -> BTree a -> Bool
BTree a -> BTree a -> Ordering
BTree a -> BTree a -> BTree a
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
forall a. Ord a => Eq (BTree a)
forall a. Ord a => BTree a -> BTree a -> Bool
forall a. Ord a => BTree a -> BTree a -> Ordering
forall a. Ord a => BTree a -> BTree a -> BTree a
$ccompare :: forall a. Ord a => BTree a -> BTree a -> Ordering
compare :: BTree a -> BTree a -> Ordering
$c< :: forall a. Ord a => BTree a -> BTree a -> Bool
< :: BTree a -> BTree a -> Bool
$c<= :: forall a. Ord a => BTree a -> BTree a -> Bool
<= :: BTree a -> BTree a -> Bool
$c> :: forall a. Ord a => BTree a -> BTree a -> Bool
> :: BTree a -> BTree a -> Bool
$c>= :: forall a. Ord a => BTree a -> BTree a -> Bool
>= :: BTree a -> BTree a -> Bool
$cmax :: forall a. Ord a => BTree a -> BTree a -> BTree a
max :: BTree a -> BTree a -> BTree a
$cmin :: forall a. Ord a => BTree a -> BTree a -> BTree a
min :: BTree a -> BTree a -> BTree a
Ord, ReadPrec [BTree a]
ReadPrec (BTree a)
Int -> ReadS (BTree a)
ReadS [BTree a]
(Int -> ReadS (BTree a))
-> ReadS [BTree a]
-> ReadPrec (BTree a)
-> ReadPrec [BTree a]
-> Read (BTree a)
forall a. Read a => ReadPrec [BTree a]
forall a. Read a => ReadPrec (BTree a)
forall a. Read a => Int -> ReadS (BTree a)
forall a. Read a => ReadS [BTree a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (BTree a)
readsPrec :: Int -> ReadS (BTree a)
$creadList :: forall a. Read a => ReadS [BTree a]
readList :: ReadS [BTree a]
$creadPrec :: forall a. Read a => ReadPrec (BTree a)
readPrec :: ReadPrec (BTree a)
$creadListPrec :: forall a. Read a => ReadPrec [BTree a]
readListPrec :: ReadPrec [BTree a]
Read, Int -> BTree a -> ShowS
[BTree a] -> ShowS
BTree a -> String
(Int -> BTree a -> ShowS)
-> (BTree a -> String) -> ([BTree a] -> ShowS) -> Show (BTree a)
forall a. Show a => Int -> BTree a -> ShowS
forall a. Show a => [BTree a] -> ShowS
forall a. Show a => BTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> BTree a -> ShowS
showsPrec :: Int -> BTree a -> ShowS
$cshow :: forall a. Show a => BTree a -> String
show :: BTree a -> String
$cshowList :: forall a. Show a => [BTree a] -> ShowS
showList :: [BTree a] -> ShowS
Show, (forall a b. (a -> b) -> BTree a -> BTree b)
-> (forall a b. a -> BTree b -> BTree a) -> Functor BTree
forall a b. a -> BTree b -> BTree a
forall a b. (a -> b) -> BTree a -> BTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> BTree a -> BTree b
fmap :: forall a b. (a -> b) -> BTree a -> BTree b
$c<$ :: forall a b. a -> BTree b -> BTree a
<$ :: forall a b. a -> BTree b -> BTree a
Functor, (forall m. Monoid m => BTree m -> m)
-> (forall m a. Monoid m => (a -> m) -> BTree a -> m)
-> (forall m a. Monoid m => (a -> m) -> BTree a -> m)
-> (forall a b. (a -> b -> b) -> b -> BTree a -> b)
-> (forall a b. (a -> b -> b) -> b -> BTree a -> b)
-> (forall b a. (b -> a -> b) -> b -> BTree a -> b)
-> (forall b a. (b -> a -> b) -> b -> BTree a -> b)
-> (forall a. (a -> a -> a) -> BTree a -> a)
-> (forall a. (a -> a -> a) -> BTree a -> a)
-> (forall a. BTree a -> [a])
-> (forall a. BTree a -> Bool)
-> (forall a. BTree a -> Int)
-> (forall a. Eq a => a -> BTree a -> Bool)
-> (forall a. Ord a => BTree a -> a)
-> (forall a. Ord a => BTree a -> a)
-> (forall a. Num a => BTree a -> a)
-> (forall a. Num a => BTree a -> a)
-> Foldable BTree
forall a. Eq a => a -> BTree a -> Bool
forall a. Num a => BTree a -> a
forall a. Ord a => BTree a -> a
forall m. Monoid m => BTree m -> m
forall a. BTree a -> Bool
forall a. BTree a -> Int
forall a. BTree a -> [a]
forall a. (a -> a -> a) -> BTree a -> a
forall m a. Monoid m => (a -> m) -> BTree a -> m
forall b a. (b -> a -> b) -> b -> BTree a -> b
forall a b. (a -> b -> b) -> b -> BTree a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => BTree m -> m
fold :: forall m. Monoid m => BTree m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> BTree a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> BTree a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> BTree a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> BTree a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> BTree a -> b
foldr :: forall a b. (a -> b -> b) -> b -> BTree a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> BTree a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> BTree a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> BTree a -> b
foldl :: forall b a. (b -> a -> b) -> b -> BTree a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> BTree a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> BTree a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> BTree a -> a
foldr1 :: forall a. (a -> a -> a) -> BTree a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> BTree a -> a
foldl1 :: forall a. (a -> a -> a) -> BTree a -> a
$ctoList :: forall a. BTree a -> [a]
toList :: forall a. BTree a -> [a]
$cnull :: forall a. BTree a -> Bool
null :: forall a. BTree a -> Bool
$clength :: forall a. BTree a -> Int
length :: forall a. BTree a -> Int
$celem :: forall a. Eq a => a -> BTree a -> Bool
elem :: forall a. Eq a => a -> BTree a -> Bool
$cmaximum :: forall a. Ord a => BTree a -> a
maximum :: forall a. Ord a => BTree a -> a
$cminimum :: forall a. Ord a => BTree a -> a
minimum :: forall a. Ord a => BTree a -> a
$csum :: forall a. Num a => BTree a -> a
sum :: forall a. Num a => BTree a -> a
$cproduct :: forall a. Num a => BTree a -> a
product :: forall a. Num a => BTree a -> a
F.Foldable, Functor BTree
Foldable BTree
(Functor BTree, Foldable BTree) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> BTree a -> f (BTree b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    BTree (f a) -> f (BTree a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> BTree a -> m (BTree b))
-> (forall (m :: * -> *) a. Monad m => BTree (m a) -> m (BTree a))
-> Traversable BTree
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => BTree (m a) -> m (BTree a)
forall (f :: * -> *) a. Applicative f => BTree (f a) -> f (BTree a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BTree a -> m (BTree b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BTree a -> f (BTree b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BTree a -> f (BTree b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BTree a -> f (BTree b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => BTree (f a) -> f (BTree a)
sequenceA :: forall (f :: * -> *) a. Applicative f => BTree (f a) -> f (BTree a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BTree a -> m (BTree b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BTree a -> m (BTree b)
$csequence :: forall (m :: * -> *) a. Monad m => BTree (m a) -> m (BTree a)
sequence :: forall (m :: * -> *) a. Monad m => BTree (m a) -> m (BTree a)
T.Traversable)

-- | Convenient constructor for leaves.
leaf :: a -> BTree a
leaf :: forall a. a -> BTree a
leaf a
a = a -> BTree a -> BTree a -> BTree a
forall a. a -> BTree a -> BTree a -> BTree a
BNode a
a BTree a
forall a. BTree a
Empty BTree a
forall a. BTree a
Empty

------------------------------------------------------------
--  Layout algorithms
------------------------------------------------------------

--------------------------------------------------
-- Unique X layout for binary trees.  No
-- two nodes share the same X coordinate.

data Pos = Pos { Pos -> Int
_level :: Int
               , Pos -> Int
_horiz :: Int
               }
  deriving (Pos -> Pos -> Bool
(Pos -> Pos -> Bool) -> (Pos -> Pos -> Bool) -> Eq Pos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
/= :: Pos -> Pos -> Bool
Eq, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
(Int -> Pos -> ShowS)
-> (Pos -> String) -> ([Pos] -> ShowS) -> Show Pos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pos -> ShowS
showsPrec :: Int -> Pos -> ShowS
$cshow :: Pos -> String
show :: Pos -> String
$cshowList :: [Pos] -> ShowS
showList :: [Pos] -> ShowS
Show)

makeLenses ''Pos

pos2Point :: Num n => n -> n -> Pos -> P2 n
pos2Point :: forall n. Num n => n -> n -> Pos -> P2 n
pos2Point n
cSep n
lSep (Pos Int
l Int
h) = (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h n -> n -> n
forall a. Num a => a -> a -> a
* n
cSep, -Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l n -> n -> n
forall a. Num a => a -> a -> a
* n
lSep)

-- | @uniqueXLayout xSep ySep t@ lays out the binary tree @t@ using a
--   simple recursive algorithm with the following properties:
--
--   * Every left subtree is completely to the left of its parent, and
--     similarly for right subtrees.
--
--   * All the nodes at a given depth in the tree have the same
--     y-coordinate. The separation distance between levels is given by
--     @ySep@.
--
--   * Every node has a unique x-coordinate. The separation between
--     successive nodes from left to right is given by @xSep@.

uniqueXLayout :: Num n => n -> n -> BTree a -> Maybe (Tree (a, P2 n))
uniqueXLayout :: forall n a. Num n => n -> n -> BTree a -> Maybe (Tree (a, P2 n))
uniqueXLayout n
cSep n
lSep BTree a
t = ((Tree (a, Pos) -> Tree (a, P2 n))
-> Maybe (Tree (a, Pos)) -> Maybe (Tree (a, P2 n))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree (a, Pos) -> Tree (a, P2 n))
 -> Maybe (Tree (a, Pos)) -> Maybe (Tree (a, P2 n)))
-> ((Pos -> P2 n) -> Tree (a, Pos) -> Tree (a, P2 n))
-> (Pos -> P2 n)
-> Maybe (Tree (a, Pos))
-> Maybe (Tree (a, P2 n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Pos) -> (a, P2 n)) -> Tree (a, Pos) -> Tree (a, P2 n)
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Pos) -> (a, P2 n)) -> Tree (a, Pos) -> Tree (a, P2 n))
-> ((Pos -> P2 n) -> (a, Pos) -> (a, P2 n))
-> (Pos -> P2 n)
-> Tree (a, Pos)
-> Tree (a, P2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pos -> P2 n) -> (a, Pos) -> (a, P2 n)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second) (n -> n -> Pos -> P2 n
forall n. Num n => n -> n -> Pos -> P2 n
pos2Point n
cSep n
lSep)
                (Maybe (Tree (a, Pos)) -> Maybe (Tree (a, P2 n)))
-> Maybe (Tree (a, Pos)) -> Maybe (Tree (a, P2 n))
forall a b. (a -> b) -> a -> b
$ State Pos (Maybe (Tree (a, Pos))) -> Pos -> Maybe (Tree (a, Pos))
forall s a. State s a -> s -> a
evalState (BTree a -> State Pos (Maybe (Tree (a, Pos)))
forall {m :: * -> *} {a}.
MonadState Pos m =>
BTree a -> m (Maybe (Tree (a, Pos)))
uniqueXLayout' BTree a
t) (Int -> Int -> Pos
Pos Int
0 Int
0)
  where uniqueXLayout' :: BTree a -> m (Maybe (Tree (a, Pos)))
uniqueXLayout' BTree a
Empty         = Maybe (Tree (a, Pos)) -> m (Maybe (Tree (a, Pos)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree (a, Pos))
forall a. Maybe a
Nothing
        uniqueXLayout' (BNode a
a BTree a
l BTree a
r) = do
          m ()
forall {m :: * -> *}. MonadState Pos m => m ()
down
          Maybe (Tree (a, Pos))
l' <- BTree a -> m (Maybe (Tree (a, Pos)))
uniqueXLayout' BTree a
l
          m ()
forall {m :: * -> *}. MonadState Pos m => m ()
up
          Pos
p  <- m Pos
forall {f :: * -> *}. MonadState Pos f => f Pos
mkNode
          m ()
forall {m :: * -> *}. MonadState Pos m => m ()
down
          Maybe (Tree (a, Pos))
r' <- BTree a -> m (Maybe (Tree (a, Pos)))
uniqueXLayout' BTree a
r
          m ()
forall {m :: * -> *}. MonadState Pos m => m ()
up
          Maybe (Tree (a, Pos)) -> m (Maybe (Tree (a, Pos)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Tree (a, Pos)) -> m (Maybe (Tree (a, Pos))))
-> Maybe (Tree (a, Pos)) -> m (Maybe (Tree (a, Pos)))
forall a b. (a -> b) -> a -> b
$ Tree (a, Pos) -> Maybe (Tree (a, Pos))
forall a. a -> Maybe a
Just ((a, Pos) -> [Tree (a, Pos)] -> Tree (a, Pos)
forall a. a -> [Tree a] -> Tree a
Node (a
a,Pos
p) ([Maybe (Tree (a, Pos))] -> [Tree (a, Pos)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Tree (a, Pos))
l', Maybe (Tree (a, Pos))
r']))
        mkNode :: f Pos
mkNode = f Pos
forall s (m :: * -> *). MonadState s m => m s
get f Pos -> f () -> f Pos
forall a b. f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ((Int -> Identity Int) -> Pos -> Identity Pos
Lens' Pos Int
horiz ((Int -> Identity Int) -> Pos -> Identity Pos) -> Int -> f ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1)

        down :: m ()
down = (Int -> Identity Int) -> Pos -> Identity Pos
Lens' Pos Int
level ((Int -> Identity Int) -> Pos -> Identity Pos) -> Int -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1
        up :: m ()
up   = (Int -> Identity Int) -> Pos -> Identity Pos
Lens' Pos Int
level ((Int -> Identity Int) -> Pos -> Identity Pos) -> Int -> m ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
-= Int
1

--------------------------------------------------
-- "Symmetric" layout of rose trees.

-- $symmetric
-- \"Symmetric\" layout of rose trees, based on the algorithm described in:
--
-- Andrew J. Kennedy. /Drawing Trees/, J Func. Prog. 6 (3): 527-534,
-- May 1996.
--
-- Trees laid out using this algorithm satisfy:
--
--   1. Nodes at a given level are always separated by at least a
--   given minimum distance.
--
--   2. Parent nodes are centered with respect to their immediate
--   offspring (though /not/ necessarily with respect to the entire
--   subtrees under them).
--
--   3. Layout commutes with mirroring: that is, the layout of a given
--   tree is the mirror image of the layout of the tree's mirror
--   image.  Put another way, there is no inherent left or right bias.
--
--   4. Identical subtrees are always rendered identically.  Put
--   another way, the layout of any subtree is independent of the rest
--   of the tree.
--
--   5. The layouts are as narrow as possible while satisfying all the
--   above constraints.

-- | A tree with /relative/ positioning information.  The @n@
--   at each node is the horizontal /offset/ from its parent.
type Rel t n a = t (a, n)

-- | Shift a RelTree horizontally.
moveTree :: Num n => n -> Rel Tree n a -> Rel Tree n a
moveTree :: forall n a. Num n => n -> Rel Tree n a -> Rel Tree n a
moveTree n
x' (Node (a
a, n
x) [Tree (a, n)]
ts) = (a, n) -> [Tree (a, n)] -> Tree (a, n)
forall a. a -> [Tree a] -> Tree a
Node (a
a, n
xn -> n -> n
forall a. Num a => a -> a -> a
+n
x') [Tree (a, n)]
ts

-- | An /extent/ is a list of pairs, recording the leftmost and
--   rightmost (absolute) horizontal positions of a tree at each
--   depth.
newtype Extent n = Extent { forall n. Extent n -> [(n, n)]
getExtent :: [(n, n)] }

extent :: ([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
extent :: forall n. ([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
extent [(n, n)] -> [(n, n)]
f = [(n, n)] -> Extent n
forall n. [(n, n)] -> Extent n
Extent ([(n, n)] -> Extent n)
-> (Extent n -> [(n, n)]) -> Extent n -> Extent n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(n, n)] -> [(n, n)]
f ([(n, n)] -> [(n, n)])
-> (Extent n -> [(n, n)]) -> Extent n -> [(n, n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extent n -> [(n, n)]
forall n. Extent n -> [(n, n)]
getExtent

consExtent :: (n, n) -> Extent n -> Extent n
consExtent :: forall n. (n, n) -> Extent n -> Extent n
consExtent = ([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
forall n. ([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
extent (([(n, n)] -> [(n, n)]) -> Extent n -> Extent n)
-> ((n, n) -> [(n, n)] -> [(n, n)])
-> (n, n)
-> Extent n
-> Extent n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)

-- | Shift an extent horizontally.
moveExtent :: Num n => n -> Extent n -> Extent n
moveExtent :: forall n. Num n => n -> Extent n -> Extent n
moveExtent n
x = (([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
forall n. ([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
extent (([(n, n)] -> [(n, n)]) -> Extent n -> Extent n)
-> (((n, n) -> (n, n)) -> [(n, n)] -> [(n, n)])
-> ((n, n) -> (n, n))
-> Extent n
-> Extent n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, n) -> (n, n)) -> [(n, n)] -> [(n, n)]
forall a b. (a -> b) -> [a] -> [b]
map) ((n -> n -> n
forall a. Num a => a -> a -> a
+n
x) (n -> n) -> (n -> n) -> (n, n) -> (n, n)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (n -> n -> n
forall a. Num a => a -> a -> a
+n
x))

-- | Reflect an extent about the vertical axis.
flipExtent :: Num n => Extent n -> Extent n
flipExtent :: forall n. Num n => Extent n -> Extent n
flipExtent = (([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
forall n. ([(n, n)] -> [(n, n)]) -> Extent n -> Extent n
extent (([(n, n)] -> [(n, n)]) -> Extent n -> Extent n)
-> (((n, n) -> (n, n)) -> [(n, n)] -> [(n, n)])
-> ((n, n) -> (n, n))
-> Extent n
-> Extent n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, n) -> (n, n)) -> [(n, n)] -> [(n, n)]
forall a b. (a -> b) -> [a] -> [b]
map) (\(n
p,n
q) -> (-n
q, -n
p))

-- | Merge two non-overlapping extents.
mergeExtents :: Extent n -> Extent n -> Extent n
mergeExtents :: forall n. Extent n -> Extent n -> Extent n
mergeExtents (Extent [(n, n)]
e1) (Extent [(n, n)]
e2) = [(n, n)] -> Extent n
forall n. [(n, n)] -> Extent n
Extent ([(n, n)] -> Extent n) -> [(n, n)] -> Extent n
forall a b. (a -> b) -> a -> b
$ [(n, n)] -> [(n, n)] -> [(n, n)]
forall {a} {b}. [(a, b)] -> [(a, b)] -> [(a, b)]
mergeExtents' [(n, n)]
e1 [(n, n)]
e2
  where

    mergeExtents' :: [(a, b)] -> [(a, b)] -> [(a, b)]
mergeExtents' [] [(a, b)]
qs = [(a, b)]
qs
    mergeExtents' [(a, b)]
ps [] = [(a, b)]
ps
    mergeExtents' ((a
p,b
_) : [(a, b)]
ps) ((a
_,b
q) : [(a, b)]
qs) = (a
p,b
q) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)] -> [(a, b)]
mergeExtents' [(a, b)]
ps [(a, b)]
qs

instance Semigroup (Extent n) where
  <> :: Extent n -> Extent n -> Extent n
(<>) = Extent n -> Extent n -> Extent n
forall n. Extent n -> Extent n -> Extent n
mergeExtents

instance Monoid (Extent n) where
  mempty :: Extent n
mempty  = [(n, n)] -> Extent n
forall n. [(n, n)] -> Extent n
Extent []
  mappend :: Extent n -> Extent n -> Extent n
mappend = Extent n -> Extent n -> Extent n
forall a. Semigroup a => a -> a -> a
(<>)

-- | Determine the amount to shift in order to \"fit\" two extents
--   next to one another.  The first argument is the separation to
--   leave between them.
fit :: (Num n, Ord n) => n -> Extent n -> Extent n -> n
fit :: forall n. (Num n, Ord n) => n -> Extent n -> Extent n -> n
fit n
hSep (Extent [(n, n)]
ps) (Extent [(n, n)]
qs) = [n] -> n
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (n
0 n -> [n] -> [n]
forall a. a -> [a] -> [a]
: ((n, n) -> (n, n) -> n) -> [(n, n)] -> [(n, n)] -> [n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(n
_,n
p) (n
q,n
_) -> n
p n -> n -> n
forall a. Num a => a -> a -> a
- n
q n -> n -> n
forall a. Num a => a -> a -> a
+ n
hSep) [(n, n)]
ps [(n, n)]
qs)

-- | Fit a list of subtree extents together using a left-biased
--   algorithm.  Compute a list of positions (relative to the leftmost
--   subtree which is considered to have position 0).
fitListL :: (Num n, Ord n) => n -> [Extent n] -> [n]
fitListL :: forall n. (Num n, Ord n) => n -> [Extent n] -> [n]
fitListL n
hSep = (Extent n, [n]) -> [n]
forall a b. (a, b) -> b
snd ((Extent n, [n]) -> [n])
-> ([Extent n] -> (Extent n, [n])) -> [Extent n] -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extent n -> Extent n -> (Extent n, n))
-> Extent n -> [Extent n] -> (Extent n, [n])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Extent n -> Extent n -> (Extent n, n)
fitOne Extent n
forall a. Monoid a => a
mempty
  where
    fitOne :: Extent n -> Extent n -> (Extent n, n)
fitOne Extent n
acc Extent n
e =
      let x :: n
x = n -> Extent n -> Extent n -> n
forall n. (Num n, Ord n) => n -> Extent n -> Extent n -> n
fit n
hSep Extent n
acc Extent n
e
      in  (Extent n
acc Extent n -> Extent n -> Extent n
forall a. Semigroup a => a -> a -> a
<> n -> Extent n -> Extent n
forall n. Num n => n -> Extent n -> Extent n
moveExtent n
x Extent n
e, n
x)

-- | Fit a list of subtree extents together with a right bias.
fitListR :: (Num n, Ord n) => n -> [Extent n] -> [n]
fitListR :: forall n. (Num n, Ord n) => n -> [Extent n] -> [n]
fitListR n
hSep = [n] -> [n]
forall a. [a] -> [a]
reverse ([n] -> [n]) -> ([Extent n] -> [n]) -> [Extent n] -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> n) -> [n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map n -> n
forall a. Num a => a -> a
negate ([n] -> [n]) -> ([Extent n] -> [n]) -> [Extent n] -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> [Extent n] -> [n]
forall n. (Num n, Ord n) => n -> [Extent n] -> [n]
fitListL n
hSep ([Extent n] -> [n])
-> ([Extent n] -> [Extent n]) -> [Extent n] -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extent n -> Extent n) -> [Extent n] -> [Extent n]
forall a b. (a -> b) -> [a] -> [b]
map Extent n -> Extent n
forall n. Num n => Extent n -> Extent n
flipExtent ([Extent n] -> [Extent n])
-> ([Extent n] -> [Extent n]) -> [Extent n] -> [Extent n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Extent n] -> [Extent n]
forall a. [a] -> [a]
reverse

-- | Compute a symmetric fitting by averaging the results of left- and
--   right-biased fitting.
fitList :: (Fractional n, Ord n) => n -> [Extent n] -> [n]
fitList :: forall n. (Fractional n, Ord n) => n -> [Extent n] -> [n]
fitList n
hSep = ([n] -> [n] -> [n]) -> ([n], [n]) -> [n]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((n -> n -> n) -> [n] -> [n] -> [n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> n -> n
forall {a}. Fractional a => a -> a -> a
mean) (([n], [n]) -> [n])
-> ([Extent n] -> ([n], [n])) -> [Extent n] -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> [Extent n] -> [n]
forall n. (Num n, Ord n) => n -> [Extent n] -> [n]
fitListL n
hSep ([Extent n] -> [n])
-> ([Extent n] -> [n]) -> [Extent n] -> ([n], [n])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& n -> [Extent n] -> [n]
forall n. (Num n, Ord n) => n -> [Extent n] -> [n]
fitListR n
hSep)
  where mean :: a -> a -> a
mean a
x a
y = (a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
y)a -> a -> a
forall {a}. Fractional a => a -> a -> a
/a
2

-- | Options for controlling the symmetric tree layout algorithm.
data SymmLayoutOpts n a =
  SLOpts { forall n a. SymmLayoutOpts n a -> n
_slHSep   :: n -- ^ Minimum horizontal
                                         --   separation between sibling
                                         --   nodes.  The default is 1.
         , forall n a. SymmLayoutOpts n a -> n
_slVSep   :: n -- ^ Vertical separation
                                         --   between adjacent levels of
                                         --   the tree.  The default is 1.
         , forall n a. SymmLayoutOpts n a -> a -> (n, n)
_slWidth  :: a -> (n, n)
           -- ^ A function for measuring the horizontal extent (a pair
           --   of x-coordinates) of an item in the tree.  The default
           --   is @const (0,0)@, that is, the nodes are considered as
           --   taking up no space, so the centers of the nodes will
           --   be separated according to the @slHSep@ and @slVSep@.
           --   However, this can be useful, /e.g./ if you have a tree
           --   of diagrams of irregular size and want to make sure no
           --   diagrams overlap.  In that case you could use
           --   @fromMaybe (0,0) . extentX@.
         , forall n a. SymmLayoutOpts n a -> a -> (n, n)
_slHeight :: a -> (n, n)
           -- ^ A function for measuring the vertical extent of an
           --   item in the tree.  The default is @const (0,0)@.  See
           --   the documentation for 'slWidth' for more information.
         }

makeLenses ''SymmLayoutOpts

instance Num n => Default (SymmLayoutOpts n a) where
  def :: SymmLayoutOpts n a
def = SLOpts
          { _slHSep :: n
_slHSep   = n
1
          , _slVSep :: n
_slVSep   = n
1
          , _slWidth :: a -> (n, n)
_slWidth  = (n, n) -> a -> (n, n)
forall a b. a -> b -> a
const (n
0,n
0)
          , _slHeight :: a -> (n, n)
_slHeight = (n, n) -> a -> (n, n)
forall a b. a -> b -> a
const (n
0,n
0)
          }

-- | Actual recursive tree layout algorithm, which returns a tree
--   layout as well as an extent.
symmLayoutR :: (Fractional n, Ord n) => SymmLayoutOpts n a -> Tree a -> (Rel Tree n a, Extent n)
symmLayoutR :: forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> Tree a -> (Rel Tree n a, Extent n)
symmLayoutR SymmLayoutOpts n a
opts (Node a
a [Tree a]
ts) = (Tree (a, n)
rt, Extent n
ext)
  where ([Tree (a, n)]
trees, [Extent n]
extents) = [(Tree (a, n), Extent n)] -> ([Tree (a, n)], [Extent n])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Tree a -> (Tree (a, n), Extent n))
-> [Tree a] -> [(Tree (a, n), Extent n)]
forall a b. (a -> b) -> [a] -> [b]
map (SymmLayoutOpts n a -> Tree a -> (Tree (a, n), Extent n)
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> Tree a -> (Rel Tree n a, Extent n)
symmLayoutR SymmLayoutOpts n a
opts) [Tree a]
ts)
        positions :: [n]
positions        = n -> [Extent n] -> [n]
forall n. (Fractional n, Ord n) => n -> [Extent n] -> [n]
fitList (SymmLayoutOpts n a
opts SymmLayoutOpts n a -> Getting n (SymmLayoutOpts n a) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (SymmLayoutOpts n a) n
forall n a (f :: * -> *).
Functor f =>
(n -> f n) -> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slHSep) [Extent n]
extents
        pTrees :: [Tree (a, n)]
pTrees           = (n -> Tree (a, n) -> Tree (a, n))
-> [n] -> [Tree (a, n)] -> [Tree (a, n)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> Tree (a, n) -> Tree (a, n)
forall n a. Num n => n -> Rel Tree n a -> Rel Tree n a
moveTree [n]
positions [Tree (a, n)]
trees
        pExtents :: [Extent n]
pExtents         = (n -> Extent n -> Extent n) -> [n] -> [Extent n] -> [Extent n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> Extent n -> Extent n
forall n. Num n => n -> Extent n -> Extent n
moveExtent [n]
positions [Extent n]
extents
        ext :: Extent n
ext              = (SymmLayoutOpts n a
optsSymmLayoutOpts n a
-> Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
-> a
-> (n, n)
forall s a. s -> Getting a s a -> a
^.Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
forall n a (f :: * -> *).
Functor f =>
((a -> (n, n)) -> f (a -> (n, n)))
-> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slWidth) a
a (n, n) -> Extent n -> Extent n
forall n. (n, n) -> Extent n -> Extent n
`consExtent` [Extent n] -> Extent n
forall a. Monoid a => [a] -> a
mconcat [Extent n]
pExtents
        rt :: Tree (a, n)
rt               = (a, n) -> [Tree (a, n)] -> Tree (a, n)
forall a. a -> [Tree a] -> Tree a
Node (a
a, n
0) [Tree (a, n)]
pTrees

-- | Symmetric tree layout algorithm specialized to binary trees.
--   Returns a tree layout as well as an extent.
symmLayoutBinR :: (Fractional n, Ord n) =>
                  SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
symmLayoutBinR :: forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
symmLayoutBinR SymmLayoutOpts n a
_    BTree a
Empty         = (Maybe (Rel Tree n a)
forall a. Maybe a
Nothing, Extent n
forall a. Monoid a => a
mempty)
symmLayoutBinR SymmLayoutOpts n a
opts (BNode a
a BTree a
l BTree a
r) = (Rel Tree n a -> Maybe (Rel Tree n a)
forall a. a -> Maybe a
Just Rel Tree n a
rt, Extent n
ext)
  where (Maybe (Rel Tree n a)
l', Extent n
extL) = SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
symmLayoutBinR SymmLayoutOpts n a
opts BTree a
l
        (Maybe (Rel Tree n a)
r', Extent n
extR) = SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
symmLayoutBinR SymmLayoutOpts n a
opts BTree a
r
        positions :: [n]
positions  = case (Maybe (Rel Tree n a)
l', Maybe (Rel Tree n a)
r') of
                       (Maybe (Rel Tree n a)
Nothing, Maybe (Rel Tree n a)
_) -> [n
0, SymmLayoutOpts n a
opts SymmLayoutOpts n a -> Getting n (SymmLayoutOpts n a) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (SymmLayoutOpts n a) n
forall n a (f :: * -> *).
Functor f =>
(n -> f n) -> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slHSep n -> n -> n
forall {a}. Fractional a => a -> a -> a
/ n
2]
                       (Maybe (Rel Tree n a)
_, Maybe (Rel Tree n a)
Nothing) -> [-(SymmLayoutOpts n a
opts SymmLayoutOpts n a -> Getting n (SymmLayoutOpts n a) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (SymmLayoutOpts n a) n
forall n a (f :: * -> *).
Functor f =>
(n -> f n) -> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slHSep) n -> n -> n
forall {a}. Fractional a => a -> a -> a
/ n
2, n
0]
                       (Maybe (Rel Tree n a), Maybe (Rel Tree n a))
_          -> n -> [Extent n] -> [n]
forall n. (Fractional n, Ord n) => n -> [Extent n] -> [n]
fitList (SymmLayoutOpts n a
opts SymmLayoutOpts n a -> Getting n (SymmLayoutOpts n a) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (SymmLayoutOpts n a) n
forall n a (f :: * -> *).
Functor f =>
(n -> f n) -> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slHSep) [Extent n
extL, Extent n
extR]
        pTrees :: [Rel Tree n a]
pTrees   = [Maybe (Rel Tree n a)] -> [Rel Tree n a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Rel Tree n a)] -> [Rel Tree n a])
-> [Maybe (Rel Tree n a)] -> [Rel Tree n a]
forall a b. (a -> b) -> a -> b
$ (n -> Maybe (Rel Tree n a) -> Maybe (Rel Tree n a))
-> [n] -> [Maybe (Rel Tree n a)] -> [Maybe (Rel Tree n a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Rel Tree n a -> Rel Tree n a)
-> Maybe (Rel Tree n a) -> Maybe (Rel Tree n a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rel Tree n a -> Rel Tree n a)
 -> Maybe (Rel Tree n a) -> Maybe (Rel Tree n a))
-> (n -> Rel Tree n a -> Rel Tree n a)
-> n
-> Maybe (Rel Tree n a)
-> Maybe (Rel Tree n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Rel Tree n a -> Rel Tree n a
forall n a. Num n => n -> Rel Tree n a -> Rel Tree n a
moveTree) [n]
positions [Maybe (Rel Tree n a)
l',Maybe (Rel Tree n a)
r']
        pExtents :: [Extent n]
pExtents = (n -> Extent n -> Extent n) -> [n] -> [Extent n] -> [Extent n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> Extent n -> Extent n
forall n. Num n => n -> Extent n -> Extent n
moveExtent [n]
positions [Extent n
extL, Extent n
extR]
        ext :: Extent n
ext = (SymmLayoutOpts n a
optsSymmLayoutOpts n a
-> Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
-> a
-> (n, n)
forall s a. s -> Getting a s a -> a
^.Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
forall n a (f :: * -> *).
Functor f =>
((a -> (n, n)) -> f (a -> (n, n)))
-> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slWidth) a
a (n, n) -> Extent n -> Extent n
forall n. (n, n) -> Extent n -> Extent n
`consExtent` [Extent n] -> Extent n
forall a. Monoid a => [a] -> a
mconcat [Extent n]
pExtents
        rt :: Rel Tree n a
rt  = (a, n) -> [Rel Tree n a] -> Rel Tree n a
forall a. a -> [Tree a] -> Tree a
Node (a
a, n
0) [Rel Tree n a]
pTrees

-- | Run the symmetric rose tree layout algorithm on a given tree,
--   resulting in the same tree annotated with node positions.
symmLayout' :: (Fractional n, Ord n) => SymmLayoutOpts n a -> Tree a -> Tree (a, P2 n)
symmLayout' :: forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> Tree a -> Tree (a, P2 n)
symmLayout' SymmLayoutOpts n a
opts = SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
forall n a.
(Num n, Ord n) =>
SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
unRelativize SymmLayoutOpts n a
opts P2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin (Rel Tree n a -> Tree (a, P2 n))
-> (Tree a -> Rel Tree n a) -> Tree a -> Tree (a, P2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rel Tree n a, Extent n) -> Rel Tree n a
forall a b. (a, b) -> a
fst ((Rel Tree n a, Extent n) -> Rel Tree n a)
-> (Tree a -> (Rel Tree n a, Extent n)) -> Tree a -> Rel Tree n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmLayoutOpts n a -> Tree a -> (Rel Tree n a, Extent n)
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> Tree a -> (Rel Tree n a, Extent n)
symmLayoutR SymmLayoutOpts n a
opts

-- | Run the symmetric rose tree layout algorithm on a given tree
--   using default options, resulting in the same tree annotated with
--   node positions.
symmLayout :: (Fractional n, Ord n) => Tree a -> Tree (a, P2 n)
symmLayout :: forall n a. (Fractional n, Ord n) => Tree a -> Tree (a, P2 n)
symmLayout = SymmLayoutOpts n a -> Tree a -> Tree (a, P2 n)
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> Tree a -> Tree (a, P2 n)
symmLayout' SymmLayoutOpts n a
forall a. Default a => a
def

-- | Lay out a binary tree using a slight variant of the symmetric
--   layout algorithm.  In particular, if a node has only a left child
--   but no right child (or vice versa), the child will be offset from
--   the parent horizontally by half the horizontal separation
--   parameter. Note that the result will be @Nothing@ if and only if
--   the input tree is @Empty@.
symmLayoutBin' :: (Fractional n, Ord n) => SymmLayoutOpts n a -> BTree a -> Maybe (Tree (a,P2 n))
symmLayoutBin' :: forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> BTree a -> Maybe (Tree (a, P2 n))
symmLayoutBin' SymmLayoutOpts n a
opts = (Rel Tree n a -> Tree (a, P2 n))
-> Maybe (Rel Tree n a) -> Maybe (Tree (a, P2 n))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
forall n a.
(Num n, Ord n) =>
SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
unRelativize SymmLayoutOpts n a
opts P2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) (Maybe (Rel Tree n a) -> Maybe (Tree (a, P2 n)))
-> (BTree a -> Maybe (Rel Tree n a))
-> BTree a
-> Maybe (Tree (a, P2 n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Rel Tree n a), Extent n) -> Maybe (Rel Tree n a)
forall a b. (a, b) -> a
fst ((Maybe (Rel Tree n a), Extent n) -> Maybe (Rel Tree n a))
-> (BTree a -> (Maybe (Rel Tree n a), Extent n))
-> BTree a
-> Maybe (Rel Tree n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> BTree a -> (Maybe (Rel Tree n a), Extent n)
symmLayoutBinR SymmLayoutOpts n a
opts

-- | Lay out a binary tree using a slight variant of the symmetric
--   layout algorithm, using default options.  In particular, if a
--   node has only a left child but no right child (or vice versa),
--   the child will be offset from the parent horizontally by half the
--   horizontal separation parameter. Note that the result will be
--   @Nothing@ if and only if the input tree is @Empty@.
symmLayoutBin :: (Fractional n, Ord n) => BTree a -> Maybe (Tree (a,P2 n))
symmLayoutBin :: forall n a.
(Fractional n, Ord n) =>
BTree a -> Maybe (Tree (a, P2 n))
symmLayoutBin = SymmLayoutOpts n a -> BTree a -> Maybe (Tree (a, P2 n))
forall n a.
(Fractional n, Ord n) =>
SymmLayoutOpts n a -> BTree a -> Maybe (Tree (a, P2 n))
symmLayoutBin' SymmLayoutOpts n a
forall a. Default a => a
def

-- | Given a fixed location for the root, turn a tree with
--   \"relative\" positioning into one with absolute locations
--   associated to all the nodes.
unRelativize :: (Num n, Ord n) =>
                SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
unRelativize :: forall n a.
(Num n, Ord n) =>
SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
unRelativize SymmLayoutOpts n a
opts P2 n
curPt (Node (a
a,n
hOffs) [Tree (a, n)]
ts)
    = (a, P2 n) -> [Tree (a, P2 n)] -> Tree (a, P2 n)
forall a. a -> [Tree a] -> Tree a
Node (a
a, P2 n
rootPt) ((Tree (a, n) -> Tree (a, P2 n))
-> [Tree (a, n)] -> [Tree (a, P2 n)]
forall a b. (a -> b) -> [a] -> [b]
map (SymmLayoutOpts n a -> P2 n -> Tree (a, n) -> Tree (a, P2 n)
forall n a.
(Num n, Ord n) =>
SymmLayoutOpts n a -> P2 n -> Rel Tree n a -> Tree (a, P2 n)
unRelativize SymmLayoutOpts n a
opts (P2 n
rootPt P2 n -> Diff (Point V2) n -> P2 n
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (n
vOffs n -> V2 n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V2 n
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unit_Y))) [Tree (a, n)]
ts)
  where rootPt :: P2 n
rootPt = P2 n
curPt P2 n -> Diff (Point V2) n -> P2 n
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (n
hOffs n -> V2 n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX)
        vOffs :: n
vOffs  = - (n, n) -> n
forall a b. (a, b) -> a
fst ((SymmLayoutOpts n a
optsSymmLayoutOpts n a
-> Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
-> a
-> (n, n)
forall s a. s -> Getting a s a -> a
^.Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
forall n a (f :: * -> *).
Functor f =>
((a -> (n, n)) -> f (a -> (n, n)))
-> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slHeight) a
a)
               n -> n -> n
forall a. Num a => a -> a -> a
+ ([n] -> n
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([n] -> n) -> ([Tree (a, n)] -> [n]) -> [Tree (a, n)] -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (a, n) -> n) -> [Tree (a, n)] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map ((n, n) -> n
forall a b. (a, b) -> b
snd ((n, n) -> n) -> (Tree (a, n) -> (n, n)) -> Tree (a, n) -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymmLayoutOpts n a
optsSymmLayoutOpts n a
-> Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
-> a
-> (n, n)
forall s a. s -> Getting a s a -> a
^.Getting (a -> (n, n)) (SymmLayoutOpts n a) (a -> (n, n))
forall n a (f :: * -> *).
Functor f =>
((a -> (n, n)) -> f (a -> (n, n)))
-> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slHeight) (a -> (n, n)) -> (Tree (a, n) -> a) -> Tree (a, n) -> (n, n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, n) -> a
forall a b. (a, b) -> a
fst ((a, n) -> a) -> (Tree (a, n) -> (a, n)) -> Tree (a, n) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, n) -> (a, n)
forall a. Tree a -> a
rootLabel) ([Tree (a, n)] -> n) -> [Tree (a, n)] -> n
forall a b. (a -> b) -> a -> b
$ [Tree (a, n)]
ts)
               n -> n -> n
forall a. Num a => a -> a -> a
+ (SymmLayoutOpts n a
opts SymmLayoutOpts n a -> Getting n (SymmLayoutOpts n a) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (SymmLayoutOpts n a) n
forall n a (f :: * -> *).
Functor f =>
(n -> f n) -> SymmLayoutOpts n a -> f (SymmLayoutOpts n a)
slVSep)

--------------------------------------------------
--  Force-directed layout of rose trees

-- $forcedirected
-- Force-directed layout of rose trees.

data ForceLayoutTreeOpts n =
  FLTOpts
  { forall n. ForceLayoutTreeOpts n -> ForceLayoutOpts n
_forceLayoutOpts :: ForceLayoutOpts n -- ^ Options to the force layout simulator, including damping.
  , forall n. ForceLayoutTreeOpts n -> n
_edgeLen         :: n -- ^ How long edges should be, ideally.
                                           --   This will be the resting length for
                                           --   the springs.
  , forall n. ForceLayoutTreeOpts n -> n
_springK         :: n -- ^ Spring constant.  The
                                           --   bigger the constant,
                                           --   the more the edges
                                           --   push/pull towards their
                                           --   resting length.
  , forall n. ForceLayoutTreeOpts n -> n
_staticK         :: n -- ^ Coulomb constant.  The
                                           --   bigger the constant, the
                                           --   more sibling nodes repel
                                           --   each other.
  }

makeLenses ''ForceLayoutTreeOpts

instance Floating n => Default (ForceLayoutTreeOpts n) where
  def :: ForceLayoutTreeOpts n
def = FLTOpts
    { _forceLayoutOpts :: ForceLayoutOpts n
_forceLayoutOpts = ForceLayoutOpts n
forall a. Default a => a
def
    , _edgeLen :: n
_edgeLen = n -> n
forall a. Floating a => a -> a
sqrt n
2
    , _springK :: n
_springK = n
0.05
    , _staticK :: n
_staticK = n
0.1
    }

-- | Assign unique ID numbers to the nodes of a tree, and generate an
--   'Ensemble' suitable for simulating in order to do force-directed
--   layout of the tree.  In particular,
--
--   * edges are modeled as springs
--
--   * nodes are modeled as point charges
--
--   * nodes are constrained to keep the same y-coordinate.
--
--   The input to @treeToEnsemble@ could be a tree already laid out by
--   some other method, such as 'uniqueXLayout'.
treeToEnsemble :: forall a n. Floating n => ForceLayoutTreeOpts n
               -> Tree (a, P2 n) -> (Tree (a, PID), Ensemble V2 n)
treeToEnsemble :: forall a n.
Floating n =>
ForceLayoutTreeOpts n
-> Tree (a, P2 n) -> (Tree (a, Int), Ensemble V2 n)
treeToEnsemble ForceLayoutTreeOpts n
opts Tree (a, P2 n)
t =
  ( (((a, P2 n), Int) -> (a, Int))
-> Tree ((a, P2 n), Int) -> Tree (a, Int)
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, P2 n) -> a) -> ((a, P2 n), Int) -> (a, Int)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a, P2 n) -> a
forall a b. (a, b) -> a
fst) Tree ((a, P2 n), Int)
lt
  , [([Edge], P2 n -> P2 n -> V2 n)]
-> Map Int (Particle V2 n) -> Ensemble V2 n
forall (v :: * -> *) n.
[([Edge], Point v n -> Point v n -> v n)]
-> Map Int (Particle v n) -> Ensemble v n
Ensemble
      [ ([Edge]
edges, \P2 n
pt1 P2 n
pt2 -> V2 n -> V2 n -> V2 n
forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX (n -> n -> P2 n -> P2 n -> V2 n
forall (v :: * -> *) n.
(Metric v, Floating n) =>
n -> n -> Point v n -> Point v n -> v n
hookeForce (ForceLayoutTreeOpts n
opts ForceLayoutTreeOpts n -> Getting n (ForceLayoutTreeOpts n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (ForceLayoutTreeOpts n) n
forall n (f :: * -> *).
Functor f =>
(n -> f n) -> ForceLayoutTreeOpts n -> f (ForceLayoutTreeOpts n)
springK) (ForceLayoutTreeOpts n
opts ForceLayoutTreeOpts n -> Getting n (ForceLayoutTreeOpts n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (ForceLayoutTreeOpts n) n
forall n (f :: * -> *).
Functor f =>
(n -> f n) -> ForceLayoutTreeOpts n -> f (ForceLayoutTreeOpts n)
edgeLen) P2 n
pt1 P2 n
pt2))
      , ([Edge]
sibs,  \P2 n
pt1 P2 n
pt2 -> V2 n -> V2 n -> V2 n
forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX (n -> P2 n -> P2 n -> V2 n
forall (v :: * -> *) n.
(Metric v, Floating n) =>
n -> Point v n -> Point v n -> v n
coulombForce (ForceLayoutTreeOpts n
opts ForceLayoutTreeOpts n -> Getting n (ForceLayoutTreeOpts n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (ForceLayoutTreeOpts n) n
forall n (f :: * -> *).
Functor f =>
(n -> f n) -> ForceLayoutTreeOpts n -> f (ForceLayoutTreeOpts n)
staticK) P2 n
pt1 P2 n
pt2))
      ]
      Map Int (Particle V2 n)
particleMap
  )

  where lt :: Tree ((a,P2 n), PID)
        lt :: Tree ((a, P2 n), Int)
lt = Tree (a, P2 n) -> Tree ((a, P2 n), Int)
forall (t :: * -> *) a. Traversable t => t a -> t (a, Int)
label Tree (a, P2 n)
t

        particleMap :: M.Map PID (Particle V2 n)
        particleMap :: Map Int (Particle V2 n)
particleMap = [(Int, Particle V2 n)] -> Map Int (Particle V2 n)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                    ([(Int, Particle V2 n)] -> Map Int (Particle V2 n))
-> (Tree ((a, P2 n), Int) -> [(Int, Particle V2 n)])
-> Tree ((a, P2 n), Int)
-> Map Int (Particle V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, P2 n) -> (Int, Particle V2 n))
-> [(Int, P2 n)] -> [(Int, Particle V2 n)]
forall a b. (a -> b) -> [a] -> [b]
map ((P2 n -> Particle V2 n) -> (Int, P2 n) -> (Int, Particle V2 n)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second P2 n -> Particle V2 n
forall (v :: * -> *) n.
(Additive v, Num n) =>
Point v n -> Particle v n
initParticle)
                    ([(Int, P2 n)] -> [(Int, Particle V2 n)])
-> (Tree ((a, P2 n), Int) -> [(Int, P2 n)])
-> Tree ((a, P2 n), Int)
-> [(Int, Particle V2 n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Int, P2 n) -> [(Int, P2 n)]
forall a. Tree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
                    (Tree (Int, P2 n) -> [(Int, P2 n)])
-> (Tree ((a, P2 n), Int) -> Tree (Int, P2 n))
-> Tree ((a, P2 n), Int)
-> [(Int, P2 n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a, P2 n), Int) -> (Int, P2 n))
-> Tree ((a, P2 n), Int) -> Tree (Int, P2 n)
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((P2 n, Int) -> (Int, P2 n)
forall {b} {a}. (b, a) -> (a, b)
swap ((P2 n, Int) -> (Int, P2 n))
-> (((a, P2 n), Int) -> (P2 n, Int))
-> ((a, P2 n), Int)
-> (Int, P2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, P2 n) -> P2 n) -> ((a, P2 n), Int) -> (P2 n, Int)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a, P2 n) -> P2 n
forall a b. (a, b) -> b
snd)
                    (Tree ((a, P2 n), Int) -> Map Int (Particle V2 n))
-> Tree ((a, P2 n), Int) -> Map Int (Particle V2 n)
forall a b. (a -> b) -> a -> b
$ Tree ((a, P2 n), Int)
lt
        swap :: (b, a) -> (a, b)
swap (b
x,a
y) = (a
y,b
x)

        edges, sibs :: [Edge]
        edges :: [Edge]
edges       = Tree Int -> [Edge]
extractEdges ((((a, P2 n), Int) -> Int) -> Tree ((a, P2 n), Int) -> Tree Int
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, P2 n), Int) -> Int
forall a b. (a, b) -> b
snd Tree ((a, P2 n), Int)
lt)
        sibs :: [Edge]
sibs        = Forest Int -> [Edge]
extractSibs [(((a, P2 n), Int) -> Int) -> Tree ((a, P2 n), Int) -> Tree Int
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, P2 n), Int) -> Int
forall a b. (a, b) -> b
snd Tree ((a, P2 n), Int)
lt]

        extractEdges :: Tree PID -> [Edge]
        extractEdges :: Tree Int -> [Edge]
extractEdges (Node Int
i Forest Int
cs) = (Tree Int -> Edge) -> Forest Int -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (((,) Int
i) (Int -> Edge) -> (Tree Int -> Int) -> Tree Int -> Edge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Int -> Int
forall a. Tree a -> a
rootLabel) Forest Int
cs
                                    [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ (Tree Int -> [Edge]) -> Forest Int -> [Edge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> [Edge]
extractEdges Forest Int
cs

        extractSibs :: Forest PID -> [Edge]
        extractSibs :: Forest Int -> [Edge]
extractSibs [] = []
        extractSibs Forest Int
ts = (\[Int]
is -> [Int] -> [Int] -> [Edge]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
is ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
tail [Int]
is)) ((Tree Int -> Int) -> Forest Int -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Tree Int -> Int
forall a. Tree a -> a
rootLabel Forest Int
ts)
                      [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ Forest Int -> [Edge]
extractSibs ((Tree Int -> Forest Int) -> Forest Int -> Forest Int
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> Forest Int
forall a. Tree a -> [Tree a]
subForest Forest Int
ts)

--        sz = ala Sum foldMap . fmap (const 1) $ t
--        sibs = [(x,y) | x <- [0..sz-2], y <- [x+1 .. sz-1]]

-- | Assign unique IDs to every node in a tree (or other traversable structure).
label :: (T.Traversable t) => t a -> t (a, PID)
label :: forall (t :: * -> *) a. Traversable t => t a -> t (a, Int)
label = (State Int (t (a, Int)) -> Int -> t (a, Int))
-> Int -> State Int (t (a, Int)) -> t (a, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int (t (a, Int)) -> Int -> t (a, Int)
forall s a. State s a -> s -> a
evalState Int
0 (State Int (t (a, Int)) -> t (a, Int))
-> (t a -> State Int (t (a, Int))) -> t a -> t (a, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> StateT Int Identity (a, Int))
-> t a -> State Int (t (a, Int))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
T.mapM (\a
a -> StateT Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get StateT Int Identity Int
-> (Int -> StateT Int Identity (a, Int))
-> StateT Int Identity (a, Int)
forall a b.
StateT Int Identity a
-> (a -> StateT Int Identity b) -> StateT Int Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i -> (Int -> Int) -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) StateT Int Identity ()
-> StateT Int Identity (a, Int) -> StateT Int Identity (a, Int)
forall a b.
StateT Int Identity a
-> StateT Int Identity b -> StateT Int Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a, Int) -> StateT Int Identity (a, Int)
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Int
i))

-- | Reconstruct a tree (or any traversable structure) from an
--   'Ensemble', given unique identifier annotations matching the
--   identifiers used in the 'Ensemble'.
reconstruct :: (Functor t, Num n) => Ensemble V2 n -> t (a, PID) -> t (a, P2 n)
reconstruct :: forall (t :: * -> *) n a.
(Functor t, Num n) =>
Ensemble V2 n -> t (a, Int) -> t (a, P2 n)
reconstruct Ensemble V2 n
e = (((a, Int) -> (a, Point V2 n)) -> t (a, Int) -> t (a, Point V2 n)
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Int) -> (a, Point V2 n)) -> t (a, Int) -> t (a, Point V2 n))
-> ((Int -> Point V2 n) -> (a, Int) -> (a, Point V2 n))
-> (Int -> Point V2 n)
-> t (a, Int)
-> t (a, Point V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Point V2 n) -> (a, Int) -> (a, Point V2 n)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second)
                  (Point V2 n -> Maybe (Point V2 n) -> Point V2 n
forall a. a -> Maybe a -> a
fromMaybe Point V2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin (Maybe (Point V2 n) -> Point V2 n)
-> (Int -> Maybe (Point V2 n)) -> Int -> Point V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Particle V2 n -> Point V2 n)
-> Maybe (Particle V2 n) -> Maybe (Point V2 n)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting (Point V2 n) (Particle V2 n) (Point V2 n)
-> Particle V2 n -> Point V2 n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Point V2 n) (Particle V2 n) (Point V2 n)
forall (v :: * -> *) n (f :: * -> *).
Functor f =>
(Point v n -> f (Point v n)) -> Particle v n -> f (Particle v n)
pos) (Maybe (Particle V2 n) -> Maybe (Point V2 n))
-> (Int -> Maybe (Particle V2 n)) -> Int -> Maybe (Point V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Map Int (Particle V2 n) -> Maybe (Particle V2 n))
-> Map Int (Particle V2 n) -> Int -> Maybe (Particle V2 n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Map Int (Particle V2 n) -> Maybe (Particle V2 n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Ensemble V2 n
eEnsemble V2 n
-> Getting
     (Map Int (Particle V2 n)) (Ensemble V2 n) (Map Int (Particle V2 n))
-> Map Int (Particle V2 n)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map Int (Particle V2 n)) (Ensemble V2 n) (Map Int (Particle V2 n))
forall (v :: * -> *) n (f :: * -> *).
Functor f =>
(Map Int (Particle v n) -> f (Map Int (Particle v n)))
-> Ensemble v n -> f (Ensemble v n)
particles))

-- | Force-directed layout of rose trees, with default parameters (for
--   more options, see 'forceLayoutTree'').  In particular,
--
--   * edges are modeled as springs
--
--   * nodes are modeled as point charges
--
--   * nodes are constrained to keep the same y-coordinate.
--
--   The input could be a tree already laid out by some other method,
--   such as 'uniqueXLayout'.
forceLayoutTree :: (Floating n, Ord n) => Tree (a, P2 n) -> Tree (a, P2 n)
forceLayoutTree :: forall n a. (Floating n, Ord n) => Tree (a, P2 n) -> Tree (a, P2 n)
forceLayoutTree = ForceLayoutTreeOpts n -> Tree (a, P2 n) -> Tree (a, P2 n)
forall n a.
(Floating n, Ord n) =>
ForceLayoutTreeOpts n -> Tree (a, P2 n) -> Tree (a, P2 n)
forceLayoutTree' ForceLayoutTreeOpts n
forall a. Default a => a
def

-- | Force-directed layout of rose trees, with configurable parameters.
forceLayoutTree' :: (Floating n, Ord n) =>
                    ForceLayoutTreeOpts n -> Tree (a, P2 n) -> Tree (a, P2 n)
forceLayoutTree' :: forall n a.
(Floating n, Ord n) =>
ForceLayoutTreeOpts n -> Tree (a, P2 n) -> Tree (a, P2 n)
forceLayoutTree' ForceLayoutTreeOpts n
opts Tree (a, P2 n)
t = Ensemble V2 n -> Tree (a, Int) -> Tree (a, P2 n)
forall (t :: * -> *) n a.
(Functor t, Num n) =>
Ensemble V2 n -> t (a, Int) -> t (a, P2 n)
reconstruct (ForceLayoutOpts n -> Ensemble V2 n -> Ensemble V2 n
forall (v :: * -> *) n.
(Metric v, Num n, Ord n) =>
ForceLayoutOpts n -> Ensemble v n -> Ensemble v n
forceLayout (ForceLayoutTreeOpts n
optsForceLayoutTreeOpts n
-> Getting
     (ForceLayoutOpts n) (ForceLayoutTreeOpts n) (ForceLayoutOpts n)
-> ForceLayoutOpts n
forall s a. s -> Getting a s a -> a
^.Getting
  (ForceLayoutOpts n) (ForceLayoutTreeOpts n) (ForceLayoutOpts n)
forall n (f :: * -> *).
Functor f =>
(ForceLayoutOpts n -> f (ForceLayoutOpts n))
-> ForceLayoutTreeOpts n -> f (ForceLayoutTreeOpts n)
forceLayoutOpts) Ensemble V2 n
e) Tree (a, Int)
ti
  where (Tree (a, Int)
ti, Ensemble V2 n
e) = ForceLayoutTreeOpts n
-> Tree (a, P2 n) -> (Tree (a, Int), Ensemble V2 n)
forall a n.
Floating n =>
ForceLayoutTreeOpts n
-> Tree (a, P2 n) -> (Tree (a, Int), Ensemble V2 n)
treeToEnsemble ForceLayoutTreeOpts n
opts Tree (a, P2 n)
t

-- | Radial layout of rose trees, adapted from Andy Pavlo,
--   "Interactive, Tree-Based Graph Visualization", p. 18
--   (<http://www.cs.cmu.edu/~pavlo/static/papers/APavloThesis032006.pdf>)
radialLayout :: Tree a -> Tree (a, P2 Double)
radialLayout :: forall a. Tree a -> Tree (a, P2 Double)
radialLayout t :: Tree a
t@(Node a
a [Tree a]
_)
  = (a, P2 Double) -> [Tree (a, P2 Double)] -> Tree (a, P2 Double)
forall a. a -> [Tree a] -> Tree a
Node (a
a, P2 Double
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) (Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
forall a.
Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
assignPos Double
0 Double
forall a. Floating a => a
pi Double
0 (NodeInfo -> Int
nodeLeaves NodeInfo
info) (Tree a -> Double
forall a. Tree a -> Double
weight Tree a
t) [Tree (a, NodeInfo)]
ts)
  where
    Node (a
_,NodeInfo
info) [Tree (a, NodeInfo)]
ts = Tree a -> Tree (a, NodeInfo)
forall a. Tree a -> Tree (a, NodeInfo)
decorate Tree a
t

-- | Implementation of radial layout: @assignPos alpha beta theta k w ts@
--
--   * @alpha@, @beta@ define the bounds of an annular wedge around the root
--   * @k@ is #leaves of root and lambda is #leaves of vertex
--   * @theta@ is ?
--   * @w@ is ?
--
--   The algorithm used is an extension of Algorithm 1, Page 18 of
--   <http://www.cs.cmu.edu/~pavlo/static/papers/APavloThesis032006.pdf>.
--   See
--   <https://drive.google.com/file/d/0B3el1oMKFsOIVGVRYzJzWGwzWDA/view>
--   for more examples.
assignPos :: Double -> Double -> Double -> Int -> Double  -> [Tree (a, NodeInfo)] -> [Tree (a, P2 Double)]
assignPos :: forall a.
Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
assignPos Double
_ Double
_ Double
_ Int
_ Double
_ [] = []
assignPos Double
alpha Double
beta Double
theta Int
k Double
w (Node (a
a, NodeInfo
info) [Tree (a, NodeInfo)]
ts1 : [Tree (a, NodeInfo)]
ts2)
  = (a, P2 Double) -> [Tree (a, P2 Double)] -> Tree (a, P2 Double)
forall a. a -> [Tree a] -> Tree a
Node (a
a, P2 Double
pt) (Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
forall a.
Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
assignPos Double
theta Double
u Double
theta Int
lambda Double
w [Tree (a, NodeInfo)]
ts1) Tree (a, P2 Double)
-> [Tree (a, P2 Double)] -> [Tree (a, P2 Double)]
forall a. a -> [a] -> [a]
: Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
forall a.
Double
-> Double
-> Double
-> Int
-> Double
-> [Tree (a, NodeInfo)]
-> [Tree (a, P2 Double)]
assignPos Double
alpha Double
beta Double
u Int
k Double
w [Tree (a, NodeInfo)]
ts2
    where
      lambda :: Int
lambda  = NodeInfo -> Int
nodeLeaves NodeInfo
info
      u :: Double
u       = Double
theta Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
beta Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
alpha) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lambda Double -> Double -> Double
forall {a}. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k
      pt :: P2 Double
pt      = (Double
PrevDim (P2 Double)
1 PrevDim (P2 Double) -> FinalCoord (P2 Double) -> P2 Double
forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& Double
FinalCoord (P2 Double)
0)
              # rotate (theta + u @@ rad)
              # scale (w * fromIntegral (nodeDepth info) / 2)

-- | Compute the length of radius determined by the number of children to avoid
--   node overlapping
weight :: Tree a -> Double
weight :: forall a. Tree a -> Double
weight Tree a
t = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$
               ([Tree a] -> Double) -> [[Tree a]] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (((\ Int
x -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x Double -> Double -> Double
forall {a}. Fractional a => a -> a -> a
/ Double
2) (Int -> Double) -> ([a] -> Int) -> [a] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([a] -> Double) -> ([Tree a] -> [a]) -> [Tree a] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree a -> a) -> [Tree a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> a
forall a. Tree a -> a
rootLabel)
                    (([Tree a] -> Bool) -> [[Tree a]] -> [[Tree a]]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> ([Tree a] -> Bool) -> [Tree a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Tree a]] -> [[Tree a]]) -> [[Tree a]] -> [[Tree a]]
forall a b. (a -> b) -> a -> b
$ ([Tree a] -> [Tree a]) -> [Tree a] -> [[Tree a]]
forall a. (a -> a) -> a -> [a]
iterate ((Tree a -> [Tree a]) -> [Tree a] -> [Tree a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [Tree a]
forall a. Tree a -> [Tree a]
subForest) [Tree a
t])

data NodeInfo = NodeInfo
  { NodeInfo -> Int
nodeLeaves :: Int
  , NodeInfo -> Int
nodeDepth  :: Int
  }

decorate :: Tree a -> Tree (a, NodeInfo)
decorate :: forall a. Tree a -> Tree (a, NodeInfo)
decorate = Int -> Tree a -> Tree (a, NodeInfo)
forall a. Int -> Tree a -> Tree (a, NodeInfo)
decorate' Int
0

decorate' :: Int -> Tree a -> Tree (a, NodeInfo)
decorate' :: forall a. Int -> Tree a -> Tree (a, NodeInfo)
decorate' Int
d (Node a
a [Tree a]
ts) = (a, NodeInfo) -> [Tree (a, NodeInfo)] -> Tree (a, NodeInfo)
forall a. a -> [Tree a] -> Tree a
Node (a
a, NodeInfo
info) [Tree (a, NodeInfo)]
ts'
  where
    ts' :: [Tree (a, NodeInfo)]
ts'   = (Tree a -> Tree (a, NodeInfo)) -> [Tree a] -> [Tree (a, NodeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Tree a -> Tree (a, NodeInfo)
forall a. Int -> Tree a -> Tree (a, NodeInfo)
decorate' (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [Tree a]
ts
    infos :: [NodeInfo]
infos = (Tree (a, NodeInfo) -> NodeInfo)
-> [Tree (a, NodeInfo)] -> [NodeInfo]
forall a b. (a -> b) -> [a] -> [b]
map ((a, NodeInfo) -> NodeInfo
forall a b. (a, b) -> b
snd ((a, NodeInfo) -> NodeInfo)
-> (Tree (a, NodeInfo) -> (a, NodeInfo))
-> Tree (a, NodeInfo)
-> NodeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, NodeInfo) -> (a, NodeInfo)
forall a. Tree a -> a
rootLabel) [Tree (a, NodeInfo)]
ts'
    leaves :: Int
leaves
      | [Tree a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tree a]
ts   = Int
1
      | Bool
otherwise = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([NodeInfo] -> [Int]) -> [NodeInfo] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeInfo -> Int) -> [NodeInfo] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map NodeInfo -> Int
nodeLeaves ([NodeInfo] -> Int) -> [NodeInfo] -> Int
forall a b. (a -> b) -> a -> b
$ [NodeInfo]
infos

    info :: NodeInfo
info  = Int -> Int -> NodeInfo
NodeInfo Int
leaves Int
d

------------------------------------------------------------
--  Rendering
------------------------------------------------------------

-- | Draw a tree annotated with node positions, given functions
--   specifying how to draw nodes and edges.
renderTree :: (Monoid' m, Floating n, Ord n)
           => (a -> QDiagram b V2 n m) -> (P2 n -> P2 n -> QDiagram b V2 n m)
           -> Tree (a, P2 n) -> QDiagram b V2 n m
renderTree :: forall m n a b.
(Monoid' m, Floating n, Ord n) =>
(a -> QDiagram b V2 n m)
-> (P2 n -> P2 n -> QDiagram b V2 n m)
-> Tree (a, P2 n)
-> QDiagram b V2 n m
renderTree a -> QDiagram b V2 n m
n P2 n -> P2 n -> QDiagram b V2 n m
e = (a -> QDiagram b V2 n m)
-> ((a, P2 n) -> (a, P2 n) -> QDiagram b V2 n m)
-> Tree (a, P2 n)
-> QDiagram b V2 n m
forall m n a b.
(Monoid' m, Floating n, Ord n) =>
(a -> QDiagram b V2 n m)
-> ((a, P2 n) -> (a, P2 n) -> QDiagram b V2 n m)
-> Tree (a, P2 n)
-> QDiagram b V2 n m
renderTree' a -> QDiagram b V2 n m
n (P2 n -> P2 n -> QDiagram b V2 n m
e (P2 n -> P2 n -> QDiagram b V2 n m)
-> ((a, P2 n) -> P2 n)
-> (a, P2 n)
-> (a, P2 n)
-> QDiagram b V2 n m
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, P2 n) -> P2 n
forall a b. (a, b) -> b
snd)

-- | Draw a tree annotated with node positions, given functions
--   specifying how to draw nodes and edges.  Unlike 'renderTree',
--   this version gives the edge-drawing function access to the actual
--   values stored at the nodes rather than just their positions.
renderTree' :: (Monoid' m, Floating n, Ord n)
           => (a -> QDiagram b V2 n m) -> ((a,P2 n) -> (a,P2 n) -> QDiagram b V2 n m)
           -> Tree (a, P2 n) -> QDiagram b V2 n m
renderTree' :: forall m n a b.
(Monoid' m, Floating n, Ord n) =>
(a -> QDiagram b V2 n m)
-> ((a, P2 n) -> (a, P2 n) -> QDiagram b V2 n m)
-> Tree (a, P2 n)
-> QDiagram b V2 n m
renderTree' a -> QDiagram b V2 n m
renderNode (a, P2 n) -> (a, P2 n) -> QDiagram b V2 n m
renderEdge = QDiagram b V2 n m -> QDiagram b V2 n m
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignT (QDiagram b V2 n m -> QDiagram b V2 n m)
-> (Tree (a, P2 n) -> QDiagram b V2 n m)
-> Tree (a, P2 n)
-> QDiagram b V2 n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QDiagram b V2 n m -> QDiagram b V2 n m
forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerX (QDiagram b V2 n m -> QDiagram b V2 n m)
-> (Tree (a, P2 n) -> QDiagram b V2 n m)
-> Tree (a, P2 n)
-> QDiagram b V2 n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, P2 n) -> QDiagram b V2 n m
renderTreeR
  where
    renderTreeR :: Tree (a, P2 n) -> QDiagram b V2 n m
renderTreeR (Node (a
a,P2 n
p) [Tree (a, P2 n)]
cs) =
         a -> QDiagram b V2 n m
renderNode a
a QDiagram b V2 n m
-> (QDiagram b V2 n m -> QDiagram b V2 n m) -> QDiagram b V2 n m
forall a b. a -> (a -> b) -> b
# P2 n -> QDiagram b V2 n m -> QDiagram b V2 n m
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo P2 n
p
      QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
forall a. Semigroup a => a -> a -> a
<> [QDiagram b V2 n m] -> QDiagram b V2 n m
forall a. Monoid a => [a] -> a
mconcat ((Tree (a, P2 n) -> QDiagram b V2 n m)
-> [Tree (a, P2 n)] -> [QDiagram b V2 n m]
forall a b. (a -> b) -> [a] -> [b]
map Tree (a, P2 n) -> QDiagram b V2 n m
renderTreeR [Tree (a, P2 n)]
cs)
      QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
forall a. Semigroup a => a -> a -> a
<> [QDiagram b V2 n m] -> QDiagram b V2 n m
forall a. Monoid a => [a] -> a
mconcat ((Tree (a, P2 n) -> QDiagram b V2 n m)
-> [Tree (a, P2 n)] -> [QDiagram b V2 n m]
forall a b. (a -> b) -> [a] -> [b]
map ((a, P2 n) -> (a, P2 n) -> QDiagram b V2 n m
renderEdge (a
a,P2 n
p) ((a, P2 n) -> QDiagram b V2 n m)
-> (Tree (a, P2 n) -> (a, P2 n))
-> Tree (a, P2 n)
-> QDiagram b V2 n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, P2 n) -> (a, P2 n)
forall a. Tree a -> a
rootLabel) [Tree (a, P2 n)]
cs)


-- > -- Critical size-limited Boltzmann generator for binary trees (used in example)
-- >
-- > import           Control.Applicative
-- > import           Control.Lens                   hiding (( # ), Empty)
-- > import           Control.Monad.Random
-- > import           Control.Monad.Reader
-- > import           Control.Monad.State
-- > import           Control.Monad.Trans.Maybe
-- >
-- > genTreeCrit :: ReaderT Int (StateT Int (MaybeT (Rand StdGen))) (BTree ())
-- > genTreeCrit = do
-- >   r <- getRandom
-- >   if r <= (1/2 :: Double)
-- >     then return Empty
-- >     else atom >> (BNode () <$> genTreeCrit <*> genTreeCrit)
-- >
-- > atom :: ReaderT Int (StateT Int (MaybeT (Rand StdGen))) ()
-- > atom = do
-- >   targetSize <- ask
-- >   curSize <- get
-- >   when (curSize >= targetSize) mzero
-- >   put (curSize + 1)
-- >
-- > genOneTree :: Int -> Int -> Double -> Maybe (BTree ())
-- > genOneTree seed size eps =
-- >   case mt of
-- >     Nothing -> Nothing
-- >     Just (t,sz) -> if sz >= minSz then Just t else Nothing
-- >
-- >   where
-- >     g          = mkStdGen seed
-- >     sizeWiggle = floor $ fromIntegral size * eps
-- >     maxSz = size + sizeWiggle
-- >     minSz = size - sizeWiggle
-- >     mt = (evalRand ?? g) . runMaybeT . (runStateT ?? 0) . (runReaderT ?? maxSz)
-- >        $ genTreeCrit
-- >
-- > genTree' :: Int -> Int -> Double -> BTree ()
-- > genTree' seed size eps =
-- >   case (genOneTree seed size eps) of
-- >     Nothing -> genTree' (seed+1) size eps
-- >     Just t  -> t
-- >
-- > genTree :: Int -> Double -> BTree ()
-- > genTree = genTree' 0