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

-- |
-- Module      :  ELynx.Topology.Rooted
-- Description :  Topologies
-- Copyright   :  (c) Dominik Schrempf, 2021
-- 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 :: NonEmpty a -> Bool
singleton NonEmpty a
xs = Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> NonEmpty a -> [a]
forall a. Int -> NonEmpty a -> [a]
N.take Int
2 NonEmpty a
xs)

-- | Rooted topologies with leaf labels.
data Topology a
  = Node {Topology a -> Forest a
forest :: Forest a}
  | Leaf {Topology a -> a
label :: a}
  deriving (Topology a -> Topology a -> Bool
(Topology a -> Topology a -> Bool)
-> (Topology a -> Topology a -> Bool) -> Eq (Topology a)
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)
Int -> ReadS (Topology a)
ReadS [Topology a]
(Int -> ReadS (Topology a))
-> ReadS [Topology a]
-> ReadPrec (Topology a)
-> ReadPrec [Topology a]
-> Read (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
[Topology a] -> ShowS
Topology a -> String
(Int -> Topology a -> ShowS)
-> (Topology a -> String)
-> ([Topology a] -> ShowS)
-> Show (Topology a)
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, Typeable (Topology a)
DataType
Constr
Typeable (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 (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Topology a))
-> (Topology a -> Constr)
-> (Topology a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Topology a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Topology a)))
-> ((forall b. Data b => b -> b) -> Topology a -> Topology a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Topology a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Topology a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Topology a -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Topology a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Topology a -> m (Topology a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Topology a -> m (Topology a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Topology a -> m (Topology a))
-> Data (Topology a)
Topology a -> DataType
Topology a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Topology a))
(forall b. Data b => b -> b) -> Topology a -> Topology a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Topology a -> c (Topology a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Topology a)
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 u. Int -> (forall d. Data d => d -> u) -> Topology a -> u
forall u. (forall d. Data d => d -> u) -> Topology a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Topology a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Topology a -> m (Topology 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))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Topology a))
$cLeaf :: Constr
$cNode :: Constr
$tTopology :: DataType
gmapMo :: (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 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 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 :: 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 d. Data d => d -> u) -> Topology a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Topology a -> [u]
gmapQr :: (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 :: (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 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 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 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 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)
$cp1Data :: forall a. Data a => Typeable (Topology a)
Data, (forall x. Topology a -> Rep (Topology a) x)
-> (forall x. Rep (Topology a) x -> Topology a)
-> Generic (Topology a)
forall x. Rep (Topology a) x -> Topology a
forall x. Topology a -> Rep (Topology a) x
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 :: (a -> b) -> Topology a -> Topology b
fmap a -> b
f (Node Forest a
ts) = Forest b -> Topology b
forall a. Forest a -> Topology a
Node (Forest b -> Topology b) -> Forest b -> Topology b
forall a b. (a -> b) -> a -> b
$ (Topology a -> Topology b) -> Forest a -> Forest b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Topology a -> Topology b
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) = b -> Topology b
forall a. a -> Topology a
Leaf (b -> Topology b) -> b -> Topology b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
lb

instance Foldable Topology where
  foldMap :: (a -> m) -> Topology a -> m
foldMap a -> m
f (Node Forest a
ts) = (Topology a -> m) -> Forest a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Topology a -> m
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 :: Topology a -> Bool
null Topology a
_ = Bool
False
  {-# INLINE null #-}

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

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

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

  (Node Forest (a -> b)
tsF) <*> :: Topology (a -> b) -> Topology a -> Topology b
<*> Topology a
tx = Forest b -> Topology b
forall a. Forest a -> Topology a
Node (Forest b -> Topology b) -> Forest b -> Topology b
forall a b. (a -> b) -> a -> b
$ Forest (a -> b)
tsF Forest (a -> b) -> (Topology (a -> b) -> Topology b) -> Forest b
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Topology (a -> b) -> Topology a -> Topology 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 (a -> b) -> Topology a -> Topology b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Topology a
tx

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

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

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

instance Monad Topology where
  (Node Forest a
ts) >>= :: Topology a -> (a -> Topology b) -> Topology b
>>= a -> Topology b
f = Forest b -> Topology b
forall a. Forest a -> Topology a
Node (Forest b -> Topology b) -> Forest b -> Topology b
forall a b. (a -> b) -> a -> b
$ (Topology a -> Topology b) -> Forest a -> Forest b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Topology a -> (a -> Topology b) -> Topology b
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) = Forest a -> ()
forall a. NFData a => a -> ()
rnf Forest a
ts
  rnf (Leaf a
lb) = a -> ()
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 :: Tree a -> Topology a
fromRoseTree (T.Node a
lb []) = a -> Topology a
forall a. a -> Topology a
Leaf a
lb
fromRoseTree (T.Node a
_ [Tree a]
xs) = Forest a -> Topology a
forall a. Forest a -> Topology a
Node (Forest a -> Topology a) -> Forest a -> Topology a
forall a b. (a -> b) -> a -> b
$ Tree a -> Topology a
forall a. Tree a -> Topology a
fromRoseTree (Tree a -> Topology a) -> NonEmpty (Tree a) -> Forest a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree a] -> NonEmpty (Tree a)
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 :: Tree e a -> Topology a
fromBranchLabelTree (R.Node e
_ a
lb []) = a -> Topology a
forall a. a -> Topology a
Leaf a
lb
fromBranchLabelTree (R.Node e
_ a
_ [Tree e a]
xs) = Forest a -> Topology a
forall a. Forest a -> Topology a
Node (Forest a -> Topology a) -> Forest a -> Topology a
forall a b. (a -> b) -> a -> b
$ Tree e a -> Topology a
forall e a. Tree e a -> Topology a
fromBranchLabelTree (Tree e a -> Topology a) -> NonEmpty (Tree e a) -> Forest a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree e a] -> NonEmpty (Tree e a)
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 :: e -> a -> Topology a -> Tree e a
toBranchLabelTreeWith e
b a
_ (Leaf a
lb) = e -> a -> Forest e a -> Tree e a
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) = e -> a -> Forest e a -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
R.Node e
b a
l (Forest e a -> Tree e a) -> Forest e a -> Tree e a
forall a b. (a -> b) -> a -> b
$ (Topology a -> Tree e a) -> [Topology a] -> Forest e a
forall a b. (a -> b) -> [a] -> [b]
map (e -> a -> Topology a -> Tree e a
forall e a. e -> a -> Topology a -> Tree e a
toBranchLabelTreeWith e
b a
l) ([Topology a] -> Forest e a) -> [Topology a] -> Forest e a
forall a b. (a -> b) -> a -> b
$ Forest a -> [Topology a]
forall a. NonEmpty a -> [a]
N.toList Forest a
ts

-- | List of leaves.
leaves :: Topology a -> [a]
leaves :: Topology a -> [a]
leaves (Leaf a
lb) = [a
lb]
leaves (Node Forest a
ts) = (Topology a -> [a]) -> Forest a -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Topology a -> [a]
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 :: [a] -> Bool
duplicates = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
go Set a
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 a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
seen Bool -> Bool -> Bool
|| Set a -> [a] -> Bool
go (a -> Set a -> Set a
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 :: Topology a -> Bool
duplicateLeaves = [a] -> Bool
forall a. Ord a => [a] -> Bool
duplicates ([a] -> Bool) -> (Topology a -> [a]) -> Topology a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topology a -> [a]
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 :: [b] -> t a -> Maybe (t b)
setLeaves [b]
xs = t (Maybe b) -> Maybe (t b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (t (Maybe b) -> Maybe (t b))
-> (t a -> t (Maybe b)) -> t a -> Maybe (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([b], t (Maybe b)) -> t (Maybe b)
forall a b. (a, b) -> b
snd (([b], t (Maybe b)) -> t (Maybe b))
-> (t a -> ([b], t (Maybe b))) -> t a -> t (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([b] -> a -> ([b], Maybe b)) -> [b] -> t a -> ([b], t (Maybe b))
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL [b] -> a -> ([b], Maybe b)
forall a p. [a] -> p -> ([a], Maybe a)
setLeafM [b]
xs
  where
    setLeafM :: [a] -> p -> ([a], Maybe a)
setLeafM [] p
_ = ([], Maybe a
forall a. Maybe a
Nothing)
    setLeafM (a
y : [a]
ys) p
_ = ([a]
ys, a -> Maybe a
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 :: t a -> t Int
identify = (Int, t Int) -> t Int
forall a b. (a, b) -> b
snd ((Int, t Int) -> t Int) -> (t a -> (Int, t Int)) -> t a -> t Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> (Int, Int)) -> Int -> t a -> (Int, t Int)
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\Int
i a
_ -> (Int
i Int -> Int -> Int
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 :: Topology a -> Int
degree (Node Forest a
ts) = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Forest a -> Int
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 :: Topology a -> Int
depth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> (Topology a -> [Int]) -> Topology a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Topology a -> [Int]
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) = (Topology a -> [t]) -> Forest a -> [t]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (t -> Topology a -> [t]
go (t
n t -> t -> t
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 :: Topology a -> Topology a
prune (Node Forest a
ts)
  | Forest a -> Bool
forall a. NonEmpty a -> Bool
singleton Forest a
ts = Forest a -> Topology a
forall a. Forest a -> Topology a
Node (Forest a -> Topology a) -> Forest a -> Topology a
forall a b. (a -> b) -> a -> b
$ (Topology a -> Topology a) -> Forest a -> Forest a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Topology a -> Topology a
forall a. Topology a -> Topology a
prune (Forest a -> Forest a) -> Forest a -> Forest a
forall a b. (a -> b) -> a -> b
$ Topology a -> Forest a
forall a. Topology a -> Forest a
forest (Topology a -> Forest a) -> Topology a -> Forest a
forall a b. (a -> b) -> a -> b
$ Forest a -> Topology a
forall a. NonEmpty a -> a
N.head Forest a
ts
  | Bool
otherwise = Forest a -> Topology a
forall a. Forest a -> Topology a
Node (Forest a -> Topology a) -> Forest a -> Topology a
forall a b. (a -> b) -> a -> b
$ (Topology a -> Topology a) -> Forest a -> Forest a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Topology a -> Topology a
forall a. Topology a -> Topology a
prune Forest a
ts
prune (Leaf a
lb) = a -> Topology a
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 :: (a -> Bool) -> Topology a -> Maybe (Topology a)
dropLeavesWith a -> Bool
p (Leaf a
lb)
  | a -> Bool
p a
lb = Maybe (Topology a)
forall a. Maybe a
Nothing
  | Bool
otherwise = Topology a -> Maybe (Topology a)
forall a. a -> Maybe a
Just (Topology a -> Maybe (Topology a))
-> Topology a -> Maybe (Topology a)
forall a b. (a -> b) -> a -> b
$ a -> Topology a
forall a. a -> Topology a
Leaf a
lb
dropLeavesWith a -> Bool
p (Node Forest a
ts) =
  if [Topology a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Topology a]
ts'
    then Maybe (Topology a)
forall a. Maybe a
Nothing
    else -- NOTE: Unnecessary conversion to and from list?
      Topology a -> Maybe (Topology a)
forall a. a -> Maybe a
Just (Topology a -> Maybe (Topology a))
-> Topology a -> Maybe (Topology a)
forall a b. (a -> b) -> a -> b
$ Forest a -> Topology a
forall a. Forest a -> Topology a
Node (Forest a -> Topology a) -> Forest a -> Topology a
forall a b. (a -> b) -> a -> b
$ [Topology a] -> Forest a
forall a. [a] -> NonEmpty a
N.fromList [Topology a]
ts'
  where
    ts' :: [Topology a]
ts' = [Maybe (Topology a)] -> [Topology a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Topology a)] -> [Topology a])
-> [Maybe (Topology a)] -> [Topology a]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe (Topology a)) -> [Maybe (Topology a)]
forall a. NonEmpty a -> [a]
N.toList (NonEmpty (Maybe (Topology a)) -> [Maybe (Topology a)])
-> NonEmpty (Maybe (Topology a)) -> [Maybe (Topology a)]
forall a b. (a -> b) -> a -> b
$ (Topology a -> Maybe (Topology a))
-> Forest a -> NonEmpty (Maybe (Topology a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Bool) -> Topology a -> Maybe (Topology a)
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 :: (a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTopologiesWith a1 -> a2 -> a
f (Node Forest a1
tsL) (Node Forest a2
tsR) =
  if Forest a1 -> Int
forall a. NonEmpty a -> Int
N.length Forest a1
tsL Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Forest a2 -> Int
forall a. NonEmpty a -> Int
N.length Forest a2
tsR
    then -- NOTE: Unnecessary conversion to and from list?
      (Topology a1 -> Topology a2 -> Maybe (Topology a))
-> [Topology a1] -> [Topology a2] -> Maybe [Topology a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ((a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
forall a1 a2 a.
(a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTopologiesWith a1 -> a2 -> a
f) (Forest a1 -> [Topology a1]
forall a. NonEmpty a -> [a]
N.toList Forest a1
tsL) (Forest a2 -> [Topology a2]
forall a. NonEmpty a -> [a]
N.toList Forest a2
tsR) Maybe [Topology a]
-> ([Topology a] -> Maybe (Topology a)) -> Maybe (Topology a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Topology a -> Maybe (Topology a)
forall a. a -> Maybe a
Just (Topology a -> Maybe (Topology a))
-> ([Topology a] -> Topology a)
-> [Topology a]
-> Maybe (Topology a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest a -> Topology a
forall a. Forest a -> Topology a
Node (Forest a -> Topology a)
-> ([Topology a] -> Forest a) -> [Topology a] -> Topology a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Topology a] -> Forest a
forall a. [a] -> NonEmpty a
N.fromList
    else Maybe (Topology a)
forall a. Maybe a
Nothing
zipTopologiesWith a1 -> a2 -> a
f (Leaf a1
lbL) (Leaf a2
lbR) = Topology a -> Maybe (Topology a)
forall a. a -> Maybe a
Just (Topology a -> Maybe (Topology a))
-> Topology a -> Maybe (Topology a)
forall a b. (a -> b) -> a -> b
$ a -> Topology a
forall a. a -> Topology a
Leaf (a -> Topology a) -> a -> Topology a
forall a b. (a -> b) -> a -> b
$ a1 -> a2 -> a
f a1
lbL a2
lbR
zipTopologiesWith a1 -> a2 -> a
_ Topology a1
_ Topology a2
_ = Maybe (Topology a)
forall a. Maybe a
Nothing

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