{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}

-- |
-- Module      :  ELynx.Topology.Rooted
-- Description :  Topologies
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Sat Jul 11 10:28:28 2020.
--
-- A rooted 'Topology' differs from a classical rooted rose 'Data.Tree.Tree' in
-- that it does not have internal node labels. The leaves have labels.
--
-- For rooted trees with branch labels, see "ELynx.Tree.Rooted".
module ELynx.Topology.Rooted
  ( -- * Data type
    Topology (..),
    Forest,
    fromRoseTree,
    fromBranchLabelTree,
    toBranchLabelTreeWith,

    -- * Access leaves, branches and labels
    leaves,
    duplicateLeaves,
    setLeaves,
    identify,

    -- * Structure
    degree,
    depth,
    prune,
    dropLeavesWith,
    zipTopologiesWith,
    zipTopologies,
  )
where

import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Data.Aeson
import Data.Data
import Data.Foldable
import Data.Functor
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as N
import Data.Maybe
import qualified Data.Set as S
import Data.Traversable
import qualified Data.Tree as T
import qualified ELynx.Tree.Rooted as R
import GHC.Generics

singleton :: NonEmpty a -> Bool
singleton :: forall a. NonEmpty a -> Bool
singleton NonEmpty a
xs = Int
1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Int -> NonEmpty a -> [a]
N.take Int
2 NonEmpty a
xs)

-- | Rooted topologies with leaf labels.
data Topology a
  = Node {forall a. Topology a -> Forest a
forest :: Forest a}
  | Leaf {forall a. Topology a -> a
label :: a}
  deriving (Topology a -> Topology a -> Bool
forall a. Eq a => Topology a -> Topology a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Topology a -> Topology a -> Bool
$c/= :: forall a. Eq a => Topology a -> Topology a -> Bool
== :: Topology a -> Topology a -> Bool
$c== :: forall a. Eq a => Topology a -> Topology a -> Bool
Eq, ReadPrec [Topology a]
ReadPrec (Topology a)
ReadS [Topology a]
forall a. Read a => ReadPrec [Topology a]
forall a. Read a => ReadPrec (Topology a)
forall a. Read a => Int -> ReadS (Topology a)
forall a. Read a => ReadS [Topology a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Topology a]
$creadListPrec :: forall a. Read a => ReadPrec [Topology a]
readPrec :: ReadPrec (Topology a)
$creadPrec :: forall a. Read a => ReadPrec (Topology a)
readList :: ReadS [Topology a]
$creadList :: forall a. Read a => ReadS [Topology a]
readsPrec :: Int -> ReadS (Topology a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Topology a)
Read, Int -> Topology a -> ShowS
forall a. Show a => Int -> Topology a -> ShowS
forall a. Show a => [Topology a] -> ShowS
forall a. Show a => Topology a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Topology a] -> ShowS
$cshowList :: forall a. Show a => [Topology a] -> ShowS
show :: Topology a -> String
$cshow :: forall a. Show a => Topology a -> String
showsPrec :: Int -> Topology a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Topology a -> ShowS
Show, Topology a -> DataType
Topology a -> Constr
forall {a}. Data a => Typeable (Topology a)
forall a. Data a => Topology a -> DataType
forall a. Data a => Topology a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> Topology a -> Topology a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Topology a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> Topology a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Topology a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Topology a -> c (Topology a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Topology a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Topology a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Topology a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Topology a -> c (Topology a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Topology a))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Topology a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Topology a -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Topology a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Topology a -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
gmapT :: (forall b. Data b => b -> b) -> Topology a -> Topology a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Topology a -> Topology a
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Topology a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Topology a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Topology a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Topology a))
dataTypeOf :: Topology a -> DataType
$cdataTypeOf :: forall a. Data a => Topology a -> DataType
toConstr :: Topology a -> Constr
$ctoConstr :: forall a. Data a => Topology a -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Topology a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Topology a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Topology a -> c (Topology a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Topology a -> c (Topology a)
Data, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Topology a) x -> Topology a
forall a x. Topology a -> Rep (Topology a) x
$cto :: forall a x. Rep (Topology a) x -> Topology a
$cfrom :: forall a x. Topology a -> Rep (Topology a) x
Generic)

-- | Shorthand.
type Forest a = NonEmpty (Topology a)

instance Functor Topology where
  fmap :: forall a b. (a -> b) -> Topology a -> Topology b
fmap a -> b
f (Node Forest a
ts) = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Forest a
ts
  fmap a -> b
f (Leaf a
lb) = forall a. a -> Topology a
Leaf forall a b. (a -> b) -> a -> b
$ a -> b
f a
lb

instance Foldable Topology where
  foldMap :: forall m a. Monoid m => (a -> m) -> Topology a -> m
foldMap a -> m
f (Node Forest a
ts) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) Forest a
ts
  foldMap a -> m
f (Leaf a
lb) = a -> m
f a
lb

  null :: forall a. Topology a -> Bool
null Topology a
_ = Bool
False
  {-# INLINE null #-}

  toList :: forall a. Topology a -> [a]
toList = forall a. Topology a -> [a]
leaves
  {-# INLINE toList #-}

instance Traversable Topology where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Topology a -> f (Topology b)
traverse a -> f b
g (Node Forest a
ts) = forall a. Forest a -> Topology a
Node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
g) Forest a
ts
  traverse a -> f b
g (Leaf a
lb) = forall a. a -> Topology a
Leaf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
g a
lb

instance Applicative Topology where
  pure :: forall a. a -> Topology a
pure = forall a. a -> Topology a
Leaf

  (Node Forest (a -> b)
tsF) <*> :: forall a b. Topology (a -> b) -> Topology a -> Topology b
<*> Topology a
tx = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ Forest (a -> b)
tsF forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Topology a
tx)
  (Leaf a -> b
lbF) <*> Topology a
tx = a -> b
lbF forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Topology a
tx

  liftA2 :: forall a b c.
(a -> b -> c) -> Topology a -> Topology b -> Topology c
liftA2 a -> b -> c
f (Node Forest a
tsX) Topology b
ty = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Topology a
tx -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Topology a
tx Topology b
ty) Forest a
tsX
  liftA2 a -> b -> c
f (Leaf a
lbX) (Node Forest b
tsY) = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> c
f a
lbX forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) Forest b
tsY
  liftA2 a -> b -> c
f (Leaf a
lbX) (Leaf b
lbY) = forall a. a -> Topology a
Leaf forall a b. (a -> b) -> a -> b
$ a -> b -> c
f a
lbX b
lbY

  (Node Forest a
tsX) *> :: forall a b. Topology a -> Topology b -> Topology b
*> Topology b
ty = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ Forest a
tsX forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Topology b
ty)
  (Leaf a
_) *> (Node NonEmpty (Topology b)
tsY) = forall a. Forest a -> Topology a
Node NonEmpty (Topology b)
tsY
  (Leaf a
_) *> (Leaf b
y) = forall a. a -> Topology a
Leaf b
y

  (Node Forest a
tsX) <* :: forall a b. Topology a -> Topology b -> Topology a
<* Topology b
ty = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ Forest a
tsX forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Topology b
ty)
  (Leaf a
x) <* Topology b
ty = a
x forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Topology b
ty

instance Monad Topology where
  (Node Forest a
ts) >>= :: forall a b. Topology a -> (a -> Topology b) -> Topology b
>>= a -> Topology b
f = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Topology b
f) Forest a
ts
  (Leaf a
lb) >>= a -> Topology b
f = a -> Topology b
f a
lb

instance NFData a => NFData (Topology a) where
  rnf :: Topology a -> ()
rnf (Node Forest a
ts) = forall a. NFData a => a -> ()
rnf Forest a
ts
  rnf (Leaf a
lb) = forall a. NFData a => a -> ()
rnf a
lb

instance ToJSON a => ToJSON (Topology a)

instance FromJSON a => FromJSON (Topology a)

-- | Convert a rooted rose tree to a rooted topology. Internal node labels are lost.
fromRoseTree :: T.Tree a -> Topology a
fromRoseTree :: forall a. Tree a -> Topology a
fromRoseTree (T.Node a
lb []) = forall a. a -> Topology a
Leaf a
lb
fromRoseTree (T.Node a
_ [Tree a]
xs) = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall a. Tree a -> Topology a
fromRoseTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> NonEmpty a
N.fromList [Tree a]
xs

-- | Convert a rooted, branch-label tree to a rooted topology. Branch labels and
-- internal node labels are lost.
fromBranchLabelTree :: R.Tree e a -> Topology a
fromBranchLabelTree :: forall e a. Tree e a -> Topology a
fromBranchLabelTree (R.Node e
_ a
lb []) = forall a. a -> Topology a
Leaf a
lb
fromBranchLabelTree (R.Node e
_ a
_ [Tree e a]
xs) = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall e a. Tree e a -> Topology a
fromBranchLabelTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> NonEmpty a
N.fromList [Tree e a]
xs

-- | Convert a rooted topology to a rooted, branch-label tree. Use the given
-- node label at internal nodes.
toBranchLabelTreeWith :: e -> a -> Topology a -> R.Tree e a
toBranchLabelTreeWith :: forall e a. e -> a -> Topology a -> Tree e a
toBranchLabelTreeWith e
b a
_ (Leaf a
lb) = forall e a. e -> a -> Forest e a -> Tree e a
R.Node e
b a
lb []
toBranchLabelTreeWith e
b a
l (Node Forest a
ts) = forall e a. e -> a -> Forest e a -> Tree e a
R.Node e
b a
l forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall e a. e -> a -> Topology a -> Tree e a
toBranchLabelTreeWith e
b a
l) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
N.toList Forest a
ts

-- | List of leaves.
leaves :: Topology a -> [a]
leaves :: forall a. Topology a -> [a]
leaves (Leaf a
lb) = [a
lb]
leaves (Node Forest a
ts) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Topology a -> [a]
leaves Forest a
ts

-- -- NOTE: This implementation of 'leaves' may be faster.
-- -- | Return leaf labels in pre-order.
-- flatten :: Topology a -> [a]
-- flatten t = squish t []
--   where
--     squish (Node ts) xs = foldr squish xs ts
--     squish (Leaf lb) xs = lb : xs

duplicates :: Ord a => [a] -> Bool
duplicates :: forall a. Ord a => [a] -> Bool
duplicates = forall {a}. Ord a => Set a -> [a] -> Bool
go forall a. Set a
S.empty
  where
    go :: Set a -> [a] -> Bool
go Set a
_ [] = Bool
False
    go Set a
seen (a
x : [a]
xs) = a
x forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
seen Bool -> Bool -> Bool
|| Set a -> [a] -> Bool
go (forall a. Ord a => a -> Set a -> Set a
S.insert a
x Set a
seen) [a]
xs

-- | Check if a topology has duplicate leaves.
duplicateLeaves :: Ord a => Topology a -> Bool
duplicateLeaves :: forall a. Ord a => Topology a -> Bool
duplicateLeaves = forall a. Ord a => [a] -> Bool
duplicates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Topology a -> [a]
leaves

-- | Set leaf labels in pre-order.
--
-- Return 'Nothing' if the provided list of leaf labels is too short.
setLeaves :: Traversable t => [b] -> t a -> Maybe (t b)
setLeaves :: forall (t :: * -> *) b a.
Traversable t =>
[b] -> t a -> Maybe (t b)
setLeaves [b]
xs = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {a} {p}. [a] -> p -> ([a], Maybe a)
setLeafM [b]
xs
  where
    setLeafM :: [a] -> p -> ([a], Maybe a)
setLeafM [] p
_ = ([], forall a. Maybe a
Nothing)
    setLeafM (a
y : [a]
ys) p
_ = ([a]
ys, forall a. a -> Maybe a
Just a
y)

-- | Label the leaves in pre-order with unique indices starting at 0.
identify :: Traversable t => t a -> t Int
identify :: forall (t :: * -> *) a. Traversable t => t a -> t Int
identify = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\Int
i a
_ -> (Int
i forall a. Num a => a -> a -> a
+ Int
1, Int
i)) (Int
0 :: Int)

-- | The degree of the root node.
degree :: Topology a -> Int
degree :: forall a. Topology a -> Int
degree (Node Forest a
ts) = (forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
ts
degree (Leaf a
_) = Int
1

-- | Depth of a topology.
--
-- See 'ELynx.Tree.Rooted.depth'.
depth :: Topology a -> Int
depth :: forall a. Topology a -> Int
depth = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {a}. Num t => t -> Topology a -> [t]
go Int
1
  where
    go :: t -> Topology a -> [t]
go t
n (Leaf a
_) = [t
n]
    go t
n (Node Forest a
xs) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> Topology a -> [t]
go (t
n forall a. Num a => a -> a -> a
+ t
1)) Forest a
xs

-- | Prune degree two nodes.
--
-- See 'ELynx.Tree.Rooted.prune'.
prune :: Topology a -> Topology a
prune :: forall a. Topology a -> Topology a
prune (Node Forest a
ts)
  | forall a. NonEmpty a -> Bool
singleton Forest a
ts = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Topology a -> Topology a
prune forall a b. (a -> b) -> a -> b
$ forall a. Topology a -> Forest a
forest forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
N.head Forest a
ts
  | Bool
otherwise = forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Topology a -> Topology a
prune Forest a
ts
prune (Leaf a
lb) = forall a. a -> Topology a
Leaf a
lb

-- | Drop leaves satisfying predicate.
--
-- See 'ELynx.Tree.Rooted.dropNodesWith'.
dropLeavesWith :: (a -> Bool) -> Topology a -> Maybe (Topology a)
dropLeavesWith :: forall a. (a -> Bool) -> Topology a -> Maybe (Topology a)
dropLeavesWith a -> Bool
p (Leaf a
lb)
  | a -> Bool
p a
lb = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Topology a
Leaf a
lb
dropLeavesWith a -> Bool
p (Node Forest a
ts) =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Topology a]
ts'
    then forall a. Maybe a
Nothing
    else -- NOTE: Unnecessary conversion to and from list?
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Forest a -> Topology a
Node forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
N.fromList [Topology a]
ts'
  where
    ts' :: [Topology a]
ts' = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
N.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> Topology a -> Maybe (Topology a)
dropLeavesWith a -> Bool
p) Forest a
ts

-- | Zip leaves of two equal topologies.
--
-- See 'ELynx.Tree.Rooted.zipTreesWith'.
zipTopologiesWith :: (a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTopologiesWith :: forall a1 a2 a.
(a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTopologiesWith a1 -> a2 -> a
f (Node Forest a1
tsL) (Node Forest a2
tsR) =
  if forall a. NonEmpty a -> Int
N.length Forest a1
tsL forall a. Eq a => a -> a -> Bool
== forall a. NonEmpty a -> Int
N.length Forest a2
tsR
    then -- NOTE: Unnecessary conversion to and from list?
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (forall a1 a2 a.
(a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTopologiesWith a1 -> a2 -> a
f) (forall a. NonEmpty a -> [a]
N.toList Forest a1
tsL) (forall a. NonEmpty a -> [a]
N.toList Forest a2
tsR) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Forest a -> Topology a
Node forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
N.fromList
    else forall a. Maybe a
Nothing
zipTopologiesWith a1 -> a2 -> a
f (Leaf a1
lbL) (Leaf a2
lbR) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Topology a
Leaf forall a b. (a -> b) -> a -> b
$ a1 -> a2 -> a
f a1
lbL a2
lbR
zipTopologiesWith a1 -> a2 -> a
_ Topology a1
_ Topology a2
_ = forall a. Maybe a
Nothing

-- | See 'zipTopologiesWith'.
zipTopologies :: Topology a1 -> Topology a2 -> Maybe (Topology (a1, a2))
zipTopologies :: forall a1 a2.
Topology a1 -> Topology a2 -> Maybe (Topology (a1, a2))
zipTopologies = forall a1 a2 a.
(a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTopologiesWith (,)