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

-- |
-- Module      :  ELynx.Topology.Rooted
-- Description :  Topologies
-- Copyright   :  (c) Dominik Schrempf, 2020
-- 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 'Topology' differs from a classical rose 'Data.Tree.Tree' in that it does
-- not have internal node labels. The leaves have labels.
--
-- For rooted trees, please see 'ELynx.Tree.Rooted'.
--
-- In phylogenetics, the order of children of a topology node is arbitrary.
-- Internally, however, the underlying 'Topology' data structure stores the
-- sub-forest as a (non-empty) list, which has a specific order. Hence, we have
-- to do some tricks when comparing topologies, and topology comparison is slow.
module ELynx.Topology.Rooted
  ( -- * Data type
    Topology (..),
    Forest,
    fromTree,
    fromLabeledTree,

    -- * Functions
    degree,
    leaves,
    flatten,
    identify,
    prune,
    dropLeavesWith,
    zipTreesWith,
    zipTrees,
    duplicateLeaves,
  )
where

import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Data.Aeson
import Data.Data
import Data.Foldable
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)

-- | A shortcut.
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]
flatten
  {-# 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

-- TODO: This type checks, but I doubt the implementation is bug-free.
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
$ (Topology (a -> b) -> Topology b) -> Forest (a -> b) -> Forest b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Topology (a -> b) -> Topology a -> Topology b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Topology a
tx) Forest (a -> b)
tsF
  (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
*> ty :: Topology b
ty@(Node Forest b
tsY) = 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 b
tsY Forest b -> Forest b -> Forest b
forall a. Semigroup a => a -> a -> a
<> (Topology a -> Topology b) -> Forest a -> Forest b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Topology a -> Topology b -> Topology b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Topology b
ty) Forest a
tsX
  (Leaf a
_) *> (Node Forest b
tsY) = Forest b -> Topology b
forall a. Forest a -> Topology a
Node Forest b
tsY
  Topology a
_ *> (Leaf b
lbY) = b -> Topology b
forall a. a -> Topology a
Leaf b
lbY

  (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
$ (Topology a -> Topology a) -> Forest a -> Forest a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Topology a -> Topology b -> Topology a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Topology b
ty) Forest a
tsX
  (Leaf a
lbX) <* Topology b
_ = a -> Topology a
forall a. a -> Topology a
Leaf a
lbX

-- TODO: This type checks, but I doubt the implementation is bug-free.
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 = case a -> Topology b
f a
lb of
    Node Forest b
ts' -> Forest b -> Topology b
forall a. Forest a -> Topology a
Node Forest b
ts'
    Leaf b
lb' -> b -> Topology b
forall a. a -> Topology a
Leaf b
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)

-- | 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

-- | Set of leaves.
leaves :: Ord a => 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. Ord a => Topology a -> [a]
leaves Forest a
ts

-- | Return leaf labels in pre-order.
flatten :: Topology a -> [a]
flatten :: Topology a -> [a]
flatten Topology a
t = Topology a -> [a] -> [a]
forall a. Topology a -> [a] -> [a]
squish Topology a
t []
  where
    squish :: Topology a -> [a] -> [a]
squish (Node Forest a
ts) [a]
xs = (Topology a -> [a] -> [a]) -> [a] -> Forest a -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Topology a -> [a] -> [a]
squish [a]
xs Forest a
ts
    squish (Leaf a
lb) [a]
xs = a
lb a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

-- TODO: Provide and fix tests, provide arbitrary instances.

-- | Convert a rooted rose tree to a rooted topology. Internal node labels are lost.
fromTree :: T.Tree a -> Topology a
fromTree :: Tree a -> Topology a
fromTree (T.Node a
lb []) = a -> Topology a
forall a. a -> Topology a
Leaf a
lb
fromTree (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
fromTree (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, labeled rose tree to a rooted topology. Branch labels and
-- internal node labels are lost.
fromLabeledTree :: R.Tree e a -> Topology a
fromLabeledTree :: Tree e a -> Topology a
fromLabeledTree (R.Node e
_ a
lb []) = a -> Topology a
forall a. a -> Topology a
Leaf a
lb
fromLabeledTree (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
fromLabeledTree (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

-- | Label the leaves with unique integers 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)

-- | Prune degree two nodes.
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.
--
-- Degree two nodes may arise.
--
-- Return 'Nothing' if all leaves satisfy the predicate.
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 -- XXX: May be slow, 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.
--
-- Return 'Nothing' if the topologies are different.
zipTreesWith :: (a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTreesWith :: (a1 -> a2 -> a) -> Topology a1 -> Topology a2 -> Maybe (Topology a)
zipTreesWith 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 -- XXX: May be slow, 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)
zipTreesWith 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
zipTreesWith 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
zipTreesWith a1 -> a2 -> a
_ Topology a1
_ Topology a2
_ = Maybe (Topology a)
forall a. Maybe a
Nothing

-- | Zip leaves of two equal topologies.
--
-- Return 'Nothing' if the topologies are different.
zipTrees :: Topology a1 -> Topology a2 -> Maybe (Topology (a1, a2))
zipTrees :: Topology a1 -> Topology a2 -> Maybe (Topology (a1, a2))
zipTrees = (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)
zipTreesWith (,)

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. Ord a => Topology a -> [a]
leaves