{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module ELynx.Tree.Bipartition
( groups,
Bipartition (fromBipartition),
bp,
bpUnsafe,
toSet,
bpHuman,
bipartition,
bipartitions,
getComplementaryLeaves,
bipartitionToBranch,
)
where
import Control.Comonad
import Control.DeepSeq
import Data.List hiding (partition)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import ELynx.Tree.Rooted
groups :: Tree e a -> Tree e [a]
groups :: forall e a. Tree e a -> Tree e [a]
groups = forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend forall e a. Tree e a -> [a]
leaves
newtype Bipartition a = Bipartition
{ forall a. Bipartition a -> (Set a, Set a)
fromBipartition :: (Set a, Set a)
}
deriving (Bipartition a -> Bipartition a -> Bool
forall a. Eq a => Bipartition a -> Bipartition a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bipartition a -> Bipartition a -> Bool
$c/= :: forall a. Eq a => Bipartition a -> Bipartition a -> Bool
== :: Bipartition a -> Bipartition a -> Bool
$c== :: forall a. Eq a => Bipartition a -> Bipartition a -> Bool
Eq, Bipartition a -> Bipartition a -> Bool
Bipartition a -> Bipartition a -> Ordering
Bipartition a -> Bipartition a -> Bipartition 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 (Bipartition a)
forall a. Ord a => Bipartition a -> Bipartition a -> Bool
forall a. Ord a => Bipartition a -> Bipartition a -> Ordering
forall a. Ord a => Bipartition a -> Bipartition a -> Bipartition a
min :: Bipartition a -> Bipartition a -> Bipartition a
$cmin :: forall a. Ord a => Bipartition a -> Bipartition a -> Bipartition a
max :: Bipartition a -> Bipartition a -> Bipartition a
$cmax :: forall a. Ord a => Bipartition a -> Bipartition a -> Bipartition a
>= :: Bipartition a -> Bipartition a -> Bool
$c>= :: forall a. Ord a => Bipartition a -> Bipartition a -> Bool
> :: Bipartition a -> Bipartition a -> Bool
$c> :: forall a. Ord a => Bipartition a -> Bipartition a -> Bool
<= :: Bipartition a -> Bipartition a -> Bool
$c<= :: forall a. Ord a => Bipartition a -> Bipartition a -> Bool
< :: Bipartition a -> Bipartition a -> Bool
$c< :: forall a. Ord a => Bipartition a -> Bipartition a -> Bool
compare :: Bipartition a -> Bipartition a -> Ordering
$ccompare :: forall a. Ord a => Bipartition a -> Bipartition a -> Ordering
Ord, Int -> Bipartition a -> ShowS
forall a. Show a => Int -> Bipartition a -> ShowS
forall a. Show a => [Bipartition a] -> ShowS
forall a. Show a => Bipartition a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bipartition a] -> ShowS
$cshowList :: forall a. Show a => [Bipartition a] -> ShowS
show :: Bipartition a -> String
$cshow :: forall a. Show a => Bipartition a -> String
showsPrec :: Int -> Bipartition a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Bipartition a -> ShowS
Show, ReadPrec [Bipartition a]
ReadPrec (Bipartition a)
ReadS [Bipartition a]
forall a. (Read a, Ord a) => ReadPrec [Bipartition a]
forall a. (Read a, Ord a) => ReadPrec (Bipartition a)
forall a. (Read a, Ord a) => Int -> ReadS (Bipartition a)
forall a. (Read a, Ord a) => ReadS [Bipartition a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Bipartition a]
$creadListPrec :: forall a. (Read a, Ord a) => ReadPrec [Bipartition a]
readPrec :: ReadPrec (Bipartition a)
$creadPrec :: forall a. (Read a, Ord a) => ReadPrec (Bipartition a)
readList :: ReadS [Bipartition a]
$creadList :: forall a. (Read a, Ord a) => ReadS [Bipartition a]
readsPrec :: Int -> ReadS (Bipartition a)
$creadsPrec :: forall a. (Read a, Ord a) => Int -> ReadS (Bipartition a)
Read, Bipartition a -> ()
forall a. NFData a => Bipartition a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Bipartition a -> ()
$crnf :: forall a. NFData a => Bipartition a -> ()
NFData)
bp :: Ord a => Set a -> Set a -> Either String (Bipartition a)
bp :: forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp Set a
xs Set a
ys
| forall a. Set a -> Bool
S.null Set a
xs = forall a b. a -> Either a b
Left String
"bp: Left set empty."
| forall a. Set a -> Bool
S.null Set a
ys = forall a b. a -> Either a b
Left String
"bp: Right set empty."
| Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Bipartition a
bpUnsafe Set a
xs Set a
ys
bpUnsafe :: Ord a => Set a -> Set a -> Bipartition a
bpUnsafe :: forall a. Ord a => Set a -> Set a -> Bipartition a
bpUnsafe Set a
xs Set a
ys = if Set a
xs forall a. Ord a => a -> a -> Bool
>= Set a
ys then forall a. (Set a, Set a) -> Bipartition a
Bipartition (Set a
xs, Set a
ys) else forall a. (Set a, Set a) -> Bipartition a
Bipartition (Set a
ys, Set a
xs)
toSet :: Ord a => Bipartition a -> Set a
toSet :: forall a. Ord a => Bipartition a -> Set a
toSet (Bipartition (Set a
x, Set a
y)) = forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
x Set a
y
bpHuman :: Show a => Bipartition a -> String
bpHuman :: forall a. Show a => Bipartition a -> String
bpHuman (Bipartition (Set a
x, Set a
y)) = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => Set a -> String
setShow Set a
x forall a. [a] -> [a] -> [a]
++ String
"|" forall a. [a] -> [a] -> [a]
++ forall a. Show a => Set a -> String
setShow Set a
y forall a. [a] -> [a] -> [a]
++ String
")"
setShow :: Show a => Set a -> String
setShow :: forall a. Show a => Set a -> String
setShow = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList
bipartition :: Ord a => Tree e a -> Either String (Bipartition a)
bipartition :: forall a e. Ord a => Tree e a -> Either String (Bipartition a)
bipartition (Node e
_ a
_ [Tree e a
x, Tree e a
y]) = forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall e a. Tree e a -> [a]
leaves Tree e a
x) (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall e a. Tree e a -> [a]
leaves Tree e a
y)
bipartition Tree e a
_ = forall a b. a -> Either a b
Left String
"bipartition: Root node is not bifurcating."
bipartitions :: Ord a => Tree e a -> Either String (Set (Bipartition a))
bipartitions :: forall a e.
Ord a =>
Tree e a -> Either String (Set (Bipartition a))
bipartitions Tree e a
t
| forall a e. Ord a => Tree e a -> Bool
duplicateLeaves Tree e a
t = forall a b. a -> Either a b
Left String
"bipartitions: Tree contains duplicate leaves."
| Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a e. Ord a => Set a -> Tree e (Set a) -> Set (Bipartition a)
bipartitions' forall a. Set a
S.empty forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Tree e a -> Tree e [a]
groups Tree e a
t
getComplementaryLeaves ::
(Ord a) =>
Set a ->
Tree e (Set a) ->
[Set a]
getComplementaryLeaves :: forall a e. Ord a => Set a -> Tree e (Set a) -> [Set a]
getComplementaryLeaves Set a
p (Node e
_ Set a
_ Forest e (Set a)
ts) =
[ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$ Set a
p forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
take Int
i [Set a]
lvsChildren forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
i forall a. Num a => a -> a -> a
+ Int
1) [Set a]
lvsChildren
| Int
i <- [Int
0 .. (Int
n forall a. Num a => a -> a -> a
- Int
1)]
]
where
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest e (Set a)
ts
lvsChildren :: [Set a]
lvsChildren = forall a b. (a -> b) -> [a] -> [b]
map forall e a. Tree e a -> a
label Forest e (Set a)
ts
bipartitions' :: Ord a => Set a -> Tree e (Set a) -> Set (Bipartition a)
bipartitions' :: forall a e. Ord a => Set a -> Tree e (Set a) -> Set (Bipartition a)
bipartitions' Set a
p (Node e
_ Set a
p' []) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
S.empty) forall a. a -> Set a
S.singleton forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp Set a
p Set a
p'
bipartitions' Set a
p t :: Tree e (Set a)
t@(Node e
_ Set a
p' [Tree e (Set a)]
ts) =
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall a b. (a -> b) -> a -> b
$
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
S.empty) forall a. a -> Set a
S.singleton (forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp Set a
p Set a
p')
forall a. a -> [a] -> [a]
: [forall a e. Ord a => Set a -> Tree e (Set a) -> Set (Bipartition a)
bipartitions' Set a
c Tree e (Set a)
s | (Set a
c, Tree e (Set a)
s) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Set a]
cs [Tree e (Set a)]
ts]
where
cs :: [Set a]
cs = forall a e. Ord a => Set a -> Tree e (Set a) -> [Set a]
getComplementaryLeaves Set a
p Tree e (Set a)
t
bipartitionToBranch ::
(Semigroup e, Ord a) =>
Tree e a ->
Either String (Map (Bipartition a) e)
bipartitionToBranch :: forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either String (Map (Bipartition a) e)
bipartitionToBranch Tree e a
t
| forall a e. Ord a => Tree e a -> Bool
duplicateLeaves Tree e a
t = forall a b. a -> Either a b
Left String
"bipartitionToBranch: Tree contains duplicate leaves."
| Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall e a.
(Semigroup e, Ord a) =>
Set a -> Tree e (Set a) -> Map (Bipartition a) e
bipartitionToBranch' forall a. Set a
S.empty Tree e (Set a)
pTree
where
pTree :: Tree e (Set a)
pTree = forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Tree e a -> Tree e [a]
groups Tree e a
t
bipartitionToBranch' ::
(Semigroup e, Ord a) =>
Set a ->
Tree e (Set a) ->
Map (Bipartition a) e
bipartitionToBranch' :: forall e a.
(Semigroup e, Ord a) =>
Set a -> Tree e (Set a) -> Map (Bipartition a) e
bipartitionToBranch' Set a
p t :: Tree e (Set a)
t@(Node e
b Set a
p' Forest e (Set a)
ts) =
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall k a. Map k a
M.empty) (forall k a. k -> a -> Map k a
`M.singleton` e
b) (forall a. Ord a => Set a -> Set a -> Either String (Bipartition a)
bp Set a
p Set a
p')
forall a. a -> [a] -> [a]
: [forall e a.
(Semigroup e, Ord a) =>
Set a -> Tree e (Set a) -> Map (Bipartition a) e
bipartitionToBranch' Set a
c Tree e (Set a)
s | (Set a
c, Tree e (Set a)
s) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Set a]
cs Forest e (Set a)
ts]
where
cs :: [Set a]
cs = forall a e. Ord a => Set a -> Tree e (Set a) -> [Set a]
getComplementaryLeaves Set a
p Tree e (Set a)
t