{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}

-- |
-- Module      :  ELynx.Tree.Length
-- Description :  Labels having a length
-- Copyright   :  (c) Dominik Schrempf 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Jan 17 14:16:34 2019.
--
-- Non-negativity of lengths is not completely ensured. See the documentation of
-- 'Length'.
module ELynx.Tree.Length
  ( -- * Non-negative length
    Length (fromLength),
    toLength,
    toLengthUnsafe,
    HasMaybeLength (..),
    HasLength (..),
    height,
    rootHeight,

    -- * Functions on trees
    distancesOriginLeaves,
    totalBranchLength,
    normalizeBranchLengths,
    normalizeHeight,
    ultrametric,
    makeUltrametric,
  )
where

import Control.DeepSeq
import Data.Aeson
import Data.Bifunctor
import Data.Default.Class
import Data.Foldable
import Data.Semigroup
import ELynx.Tree.Rooted
import ELynx.Tree.Splittable
import GHC.Generics

-- | Non-negative length.
--
-- However, non-negativity is only checked with 'toLength', and negative values
-- can be obtained using the 'Num' and related instances.
--
-- Safe conversion is roughly 50 percent slower.
--
-- @
-- benchmarking length/length sum foldl' with safe conversion
-- time                 110.4 ms   (109.8 ms .. 111.0 ms)
--                      1.000 R²   (1.000 R² .. 1.000 R²)
-- mean                 110.2 ms   (110.0 ms .. 110.6 ms)
-- std dev              501.8 μs   (359.1 μs .. 730.0 μs)
--
-- benchmarking length/length sum foldl' num instance
-- time                 89.37 ms   (85.13 ms .. 94.27 ms)
--                      0.996 R²   (0.992 R² .. 1.000 R²)
-- mean                 86.53 ms   (85.63 ms .. 88.52 ms)
-- std dev              2.239 ms   (1.069 ms .. 3.421 ms)
--
-- benchmarking length/double sum foldl'
-- time                 85.47 ms   (84.88 ms .. 86.42 ms)
--                      1.000 R²   (0.999 R² .. 1.000 R²)
-- mean                 85.56 ms   (85.26 ms .. 86.02 ms)
-- std dev              611.9 μs   (101.5 μs .. 851.7 μs)
-- @
newtype Length = Length {Length -> Double
fromLength :: Double}
  deriving (ReadPrec [Length]
ReadPrec Length
Int -> ReadS Length
ReadS [Length]
(Int -> ReadS Length)
-> ReadS [Length]
-> ReadPrec Length
-> ReadPrec [Length]
-> Read Length
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Length]
$creadListPrec :: ReadPrec [Length]
readPrec :: ReadPrec Length
$creadPrec :: ReadPrec Length
readList :: ReadS [Length]
$creadList :: ReadS [Length]
readsPrec :: Int -> ReadS Length
$creadsPrec :: Int -> ReadS Length
Read, Int -> Length -> ShowS
[Length] -> ShowS
Length -> String
(Int -> Length -> ShowS)
-> (Length -> String) -> ([Length] -> ShowS) -> Show Length
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Length] -> ShowS
$cshowList :: [Length] -> ShowS
show :: Length -> String
$cshow :: Length -> String
showsPrec :: Int -> Length -> ShowS
$cshowsPrec :: Int -> Length -> ShowS
Show, (forall x. Length -> Rep Length x)
-> (forall x. Rep Length x -> Length) -> Generic Length
forall x. Rep Length x -> Length
forall x. Length -> Rep Length x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Length x -> Length
$cfrom :: forall x. Length -> Rep Length x
Generic, Length -> ()
(Length -> ()) -> NFData Length
forall a. (a -> ()) -> NFData a
rnf :: Length -> ()
$crnf :: Length -> ()
NFData)
  deriving
    ( Length
Length -> Default Length
forall a. a -> Default a
def :: Length
$cdef :: Length
Default,
      Int -> Length
Length -> Int
Length -> [Length]
Length -> Length
Length -> Length -> [Length]
Length -> Length -> Length -> [Length]
(Length -> Length)
-> (Length -> Length)
-> (Int -> Length)
-> (Length -> Int)
-> (Length -> [Length])
-> (Length -> Length -> [Length])
-> (Length -> Length -> [Length])
-> (Length -> Length -> Length -> [Length])
-> Enum Length
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Length -> Length -> Length -> [Length]
$cenumFromThenTo :: Length -> Length -> Length -> [Length]
enumFromTo :: Length -> Length -> [Length]
$cenumFromTo :: Length -> Length -> [Length]
enumFromThen :: Length -> Length -> [Length]
$cenumFromThen :: Length -> Length -> [Length]
enumFrom :: Length -> [Length]
$cenumFrom :: Length -> [Length]
fromEnum :: Length -> Int
$cfromEnum :: Length -> Int
toEnum :: Int -> Length
$ctoEnum :: Int -> Length
pred :: Length -> Length
$cpred :: Length -> Length
succ :: Length -> Length
$csucc :: Length -> Length
Enum,
      Length -> Length -> Bool
(Length -> Length -> Bool)
-> (Length -> Length -> Bool) -> Eq Length
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Length -> Length -> Bool
$c/= :: Length -> Length -> Bool
== :: Length -> Length -> Bool
$c== :: Length -> Length -> Bool
Eq,
      Fractional Length
Length
Fractional Length
-> Length
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length -> Length)
-> (Length -> Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> Floating Length
Length -> Length
Length -> Length -> Length
forall a.
Fractional a
-> a
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> Floating a
log1mexp :: Length -> Length
$clog1mexp :: Length -> Length
log1pexp :: Length -> Length
$clog1pexp :: Length -> Length
expm1 :: Length -> Length
$cexpm1 :: Length -> Length
log1p :: Length -> Length
$clog1p :: Length -> Length
atanh :: Length -> Length
$catanh :: Length -> Length
acosh :: Length -> Length
$cacosh :: Length -> Length
asinh :: Length -> Length
$casinh :: Length -> Length
tanh :: Length -> Length
$ctanh :: Length -> Length
cosh :: Length -> Length
$ccosh :: Length -> Length
sinh :: Length -> Length
$csinh :: Length -> Length
atan :: Length -> Length
$catan :: Length -> Length
acos :: Length -> Length
$cacos :: Length -> Length
asin :: Length -> Length
$casin :: Length -> Length
tan :: Length -> Length
$ctan :: Length -> Length
cos :: Length -> Length
$ccos :: Length -> Length
sin :: Length -> Length
$csin :: Length -> Length
logBase :: Length -> Length -> Length
$clogBase :: Length -> Length -> Length
** :: Length -> Length -> Length
$c** :: Length -> Length -> Length
sqrt :: Length -> Length
$csqrt :: Length -> Length
log :: Length -> Length
$clog :: Length -> Length
exp :: Length -> Length
$cexp :: Length -> Length
pi :: Length
$cpi :: Length
$cp1Floating :: Fractional Length
Floating,
      Num Length
Num Length
-> (Length -> Length -> Length)
-> (Length -> Length)
-> (Rational -> Length)
-> Fractional Length
Rational -> Length
Length -> Length
Length -> Length -> Length
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Length
$cfromRational :: Rational -> Length
recip :: Length -> Length
$crecip :: Length -> Length
/ :: Length -> Length -> Length
$c/ :: Length -> Length -> Length
$cp1Fractional :: Num Length
Fractional,
      Integer -> Length
Length -> Length
Length -> Length -> Length
(Length -> Length -> Length)
-> (Length -> Length -> Length)
-> (Length -> Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Length -> Length)
-> (Integer -> Length)
-> Num Length
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Length
$cfromInteger :: Integer -> Length
signum :: Length -> Length
$csignum :: Length -> Length
abs :: Length -> Length
$cabs :: Length -> Length
negate :: Length -> Length
$cnegate :: Length -> Length
* :: Length -> Length -> Length
$c* :: Length -> Length -> Length
- :: Length -> Length -> Length
$c- :: Length -> Length -> Length
+ :: Length -> Length -> Length
$c+ :: Length -> Length -> Length
Num,
      Eq Length
Eq Length
-> (Length -> Length -> Ordering)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Length)
-> (Length -> Length -> Length)
-> Ord Length
Length -> Length -> Bool
Length -> Length -> Ordering
Length -> Length -> Length
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
min :: Length -> Length -> Length
$cmin :: Length -> Length -> Length
max :: Length -> Length -> Length
$cmax :: Length -> Length -> Length
>= :: Length -> Length -> Bool
$c>= :: Length -> Length -> Bool
> :: Length -> Length -> Bool
$c> :: Length -> Length -> Bool
<= :: Length -> Length -> Bool
$c<= :: Length -> Length -> Bool
< :: Length -> Length -> Bool
$c< :: Length -> Length -> Bool
compare :: Length -> Length -> Ordering
$ccompare :: Length -> Length -> Ordering
$cp1Ord :: Eq Length
Ord,
      Num Length
Ord Length
Num Length -> Ord Length -> (Length -> Rational) -> Real Length
Length -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Length -> Rational
$ctoRational :: Length -> Rational
$cp2Real :: Ord Length
$cp1Real :: Num Length
Real,
      Floating Length
RealFrac Length
RealFrac Length
-> Floating Length
-> (Length -> Integer)
-> (Length -> Int)
-> (Length -> (Int, Int))
-> (Length -> (Integer, Int))
-> (Integer -> Int -> Length)
-> (Length -> Int)
-> (Length -> Length)
-> (Int -> Length -> Length)
-> (Length -> Bool)
-> (Length -> Bool)
-> (Length -> Bool)
-> (Length -> Bool)
-> (Length -> Bool)
-> (Length -> Length -> Length)
-> RealFloat Length
Int -> Length -> Length
Integer -> Int -> Length
Length -> Bool
Length -> Int
Length -> Integer
Length -> (Int, Int)
Length -> (Integer, Int)
Length -> Length
Length -> Length -> Length
forall a.
RealFrac a
-> Floating a
-> (a -> Integer)
-> (a -> Int)
-> (a -> (Int, Int))
-> (a -> (Integer, Int))
-> (Integer -> Int -> a)
-> (a -> Int)
-> (a -> a)
-> (Int -> a -> a)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> Bool)
-> (a -> a -> a)
-> RealFloat a
atan2 :: Length -> Length -> Length
$catan2 :: Length -> Length -> Length
isIEEE :: Length -> Bool
$cisIEEE :: Length -> Bool
isNegativeZero :: Length -> Bool
$cisNegativeZero :: Length -> Bool
isDenormalized :: Length -> Bool
$cisDenormalized :: Length -> Bool
isInfinite :: Length -> Bool
$cisInfinite :: Length -> Bool
isNaN :: Length -> Bool
$cisNaN :: Length -> Bool
scaleFloat :: Int -> Length -> Length
$cscaleFloat :: Int -> Length -> Length
significand :: Length -> Length
$csignificand :: Length -> Length
exponent :: Length -> Int
$cexponent :: Length -> Int
encodeFloat :: Integer -> Int -> Length
$cencodeFloat :: Integer -> Int -> Length
decodeFloat :: Length -> (Integer, Int)
$cdecodeFloat :: Length -> (Integer, Int)
floatRange :: Length -> (Int, Int)
$cfloatRange :: Length -> (Int, Int)
floatDigits :: Length -> Int
$cfloatDigits :: Length -> Int
floatRadix :: Length -> Integer
$cfloatRadix :: Length -> Integer
$cp2RealFloat :: Floating Length
$cp1RealFloat :: RealFrac Length
RealFloat,
      Fractional Length
Real Length
Real Length
-> Fractional Length
-> (forall b. Integral b => Length -> (b, Length))
-> (forall b. Integral b => Length -> b)
-> (forall b. Integral b => Length -> b)
-> (forall b. Integral b => Length -> b)
-> (forall b. Integral b => Length -> b)
-> RealFrac Length
Length -> b
Length -> b
Length -> b
Length -> b
Length -> (b, Length)
forall b. Integral b => Length -> b
forall b. Integral b => Length -> (b, Length)
forall a.
Real a
-> Fractional a
-> (forall b. Integral b => a -> (b, a))
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> RealFrac a
floor :: Length -> b
$cfloor :: forall b. Integral b => Length -> b
ceiling :: Length -> b
$cceiling :: forall b. Integral b => Length -> b
round :: Length -> b
$cround :: forall b. Integral b => Length -> b
truncate :: Length -> b
$ctruncate :: forall b. Integral b => Length -> b
properFraction :: Length -> (b, Length)
$cproperFraction :: forall b. Integral b => Length -> (b, Length)
$cp2RealFrac :: Fractional Length
$cp1RealFrac :: Real Length
RealFrac
    )
    via Double
  deriving (b -> Length -> Length
NonEmpty Length -> Length
Length -> Length -> Length
(Length -> Length -> Length)
-> (NonEmpty Length -> Length)
-> (forall b. Integral b => b -> Length -> Length)
-> Semigroup Length
forall b. Integral b => b -> Length -> Length
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Length -> Length
$cstimes :: forall b. Integral b => b -> Length -> Length
sconcat :: NonEmpty Length -> Length
$csconcat :: NonEmpty Length -> Length
<> :: Length -> Length -> Length
$c<> :: Length -> Length -> Length
Semigroup, Semigroup Length
Length
Semigroup Length
-> Length
-> (Length -> Length -> Length)
-> ([Length] -> Length)
-> Monoid Length
[Length] -> Length
Length -> Length -> Length
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Length] -> Length
$cmconcat :: [Length] -> Length
mappend :: Length -> Length -> Length
$cmappend :: Length -> Length -> Length
mempty :: Length
$cmempty :: Length
$cp1Monoid :: Semigroup Length
Monoid) via Sum Double

instance Splittable Length where
  split :: Length -> Length
split = (Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Length
2.0)

instance ToJSON Length

instance FromJSON Length

instance HasMaybeLength Length where
  getMaybeLength :: Length -> Maybe Length
getMaybeLength = Length -> Maybe Length
forall a. a -> Maybe a
Just

instance HasLength Length where
  getLength :: Length -> Length
getLength = Length -> Length
forall a. a -> a
id
  setLength :: Length -> Length -> Length
setLength = Length -> Length -> Length
forall a b. a -> b -> a
const
  modifyLength :: (Length -> Length) -> Length -> Length
modifyLength Length -> Length
f = Length -> Length
f

-- | Return 'Left' if negative.
toLength :: Double -> Either String Length
toLength :: Double -> Either String Length
toLength Double
x
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 = String -> Either String Length
forall a b. a -> Either a b
Left (String -> Either String Length) -> String -> Either String Length
forall a b. (a -> b) -> a -> b
$ String
"Length is negative: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
  | Bool
otherwise = Length -> Either String Length
forall a b. b -> Either a b
Right (Length -> Either String Length) -> Length -> Either String Length
forall a b. (a -> b) -> a -> b
$ Double -> Length
Length Double
x

-- | Do not check if value is negative.
toLengthUnsafe :: Double -> Length
toLengthUnsafe :: Double -> Length
toLengthUnsafe = Double -> Length
Length

-- | Class of data types that may have a length.
class HasMaybeLength e where
  getMaybeLength :: e -> Maybe Length

instance HasMaybeLength () where
  getMaybeLength :: () -> Maybe Length
getMaybeLength = Maybe Length -> () -> Maybe Length
forall a b. a -> b -> a
const Maybe Length
forall a. Maybe a
Nothing

-- | Class of data types with measurable and modifiable length.
class HasMaybeLength e => HasLength e where
  getLength :: e -> Length
  setLength :: Length -> e -> e
  modifyLength :: (Length -> Length) -> e -> e

-- | The maximum distance between origin and leaves.
--
-- The height includes the branch length of the stem.
height :: HasLength e => Tree e a -> Length
height :: Tree e a -> Length
height = [Length] -> Length
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Length] -> Length)
-> (Tree e a -> [Length]) -> Tree e a -> Length
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree e a -> [Length]
forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves

-- | The maximum distance between root node and leaves.
rootHeight :: HasLength e => Tree e a -> Length
rootHeight :: Tree e a -> Length
rootHeight (Node e
_ a
_ []) = Length
0
rootHeight Tree e a
t = [Length] -> Length
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Length] -> Length) -> [Length] -> Length
forall a b. (a -> b) -> a -> b
$ (Tree e a -> [Length]) -> [Tree e a] -> [Length]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree e a -> [Length]
forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves (Tree e a -> [Tree e a]
forall e a. Tree e a -> Forest e a
forest Tree e a
t)

-- | Distances from the origin of a tree to the leaves.
--
-- The distances include the branch length of the stem.
distancesOriginLeaves :: HasLength e => Tree e a -> [Length]
distancesOriginLeaves :: Tree e a -> [Length]
distancesOriginLeaves (Node e
br a
_ []) = [e -> Length
forall e. HasLength e => e -> Length
getLength e
br]
distancesOriginLeaves (Node e
br a
_ [Tree e a]
ts) = (Length -> Length) -> [Length] -> [Length]
forall a b. (a -> b) -> [a] -> [b]
map (e -> Length
forall e. HasLength e => e -> Length
getLength e
br Length -> Length -> Length
forall a. Num a => a -> a -> a
+) ((Tree e a -> [Length]) -> [Tree e a] -> [Length]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree e a -> [Length]
forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves [Tree e a]
ts)

-- | Total branch length of a tree.
totalBranchLength :: HasLength e => Tree e a -> Length
totalBranchLength :: Tree e a -> Length
totalBranchLength = (Length -> Length -> Length)
-> Length -> ZipBranchTree a Length -> Length
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Length -> Length -> Length
forall a. Num a => a -> a -> a
(+) Length
0 (ZipBranchTree a Length -> Length)
-> (Tree e a -> ZipBranchTree a Length) -> Tree e a -> Length
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Length) -> ZipBranchTree a e -> ZipBranchTree a Length
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Length
forall e. HasLength e => e -> Length
getLength (ZipBranchTree a e -> ZipBranchTree a Length)
-> (Tree e a -> ZipBranchTree a e)
-> Tree e a
-> ZipBranchTree a Length
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree e a -> ZipBranchTree a e
forall a e. Tree e a -> ZipBranchTree a e
ZipBranchTree

-- | Normalize branch lengths so that the sum is 1.0.
normalizeBranchLengths :: HasLength e => Tree e a -> Tree e a
normalizeBranchLengths :: Tree e a -> Tree e a
normalizeBranchLengths Tree e a
t = (e -> e) -> Tree e a -> Tree e a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Length
s)) Tree e a
t
  where
    s :: Length
s = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
totalBranchLength Tree e a
t

-- | Normalize height of tree to 1.0.
normalizeHeight :: HasLength e => Tree e a -> Tree e a
normalizeHeight :: Tree e a -> Tree e a
normalizeHeight Tree e a
t = (e -> e) -> Tree e a -> Tree e a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Length
h)) Tree e a
t
  where
    h :: Length
h = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
t

eps :: Double
eps :: Double
eps = Double
1e-12

allNearlyEqual :: [Length] -> Bool
allNearlyEqual :: [Length] -> Bool
allNearlyEqual [] = Bool
True
allNearlyEqual [Length]
xs = (Length -> Bool) -> [Length] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Length
y -> Double
eps Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double -> Double
forall a. Num a => a -> a
abs (Length -> Double
fromLength (Length -> Double) -> Length -> Double
forall a b. (a -> b) -> a -> b
$ Length
x Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
y)) ([Length] -> [Length]
forall a. [a] -> [a]
tail [Length]
xs)
  where
    x :: Length
x = [Length] -> Length
forall a. [a] -> a
head [Length]
xs

-- | Check if a tree is ultrametric.
ultrametric :: HasLength e => Tree e a -> Bool
ultrametric :: Tree e a -> Bool
ultrametric = [Length] -> Bool
allNearlyEqual ([Length] -> Bool) -> (Tree e a -> [Length]) -> Tree e a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree e a -> [Length]
forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves

-- | Elongate terminal branches such that the tree becomes ultrametric.
makeUltrametric :: HasLength e => Tree e a -> Tree e a
makeUltrametric :: Tree e a -> Tree e a
makeUltrametric Tree e a
t = Length -> Tree e a -> Tree e a
forall e a. HasLength e => Length -> Tree e a -> Tree e a
go Length
0 Tree e a
t
  where
    h :: Length
h = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
t
    go :: HasLength e => Length -> Tree e a -> Tree e a
    go :: Length -> Tree e a -> Tree e a
go Length
h' (Node e
br a
lb []) = let dh :: Length
dh = Length
h Length -> Length -> Length
forall a. Num a => a -> a -> a
- Length
h' Length -> Length -> Length
forall a. Num a => a -> a -> a
- e -> Length
forall e. HasLength e => e -> Length
getLength e
br in e -> a -> [Tree e a] -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node ((Length -> Length) -> e -> e
forall e. HasLength e => (Length -> Length) -> e -> e
modifyLength (Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
dh) e
br) a
lb []
    go Length
h' (Node e
br a
lb [Tree e a]
ts) = let h'' :: Length
h'' = Length
h' Length -> Length -> Length
forall a. Num a => a -> a -> a
+ e -> Length
forall e. HasLength e => e -> Length
getLength e
br in e -> a -> [Tree e a] -> Tree e a
forall e a. e -> a -> Forest e a -> Tree e a
Node e
br a
lb ([Tree e a] -> Tree e a) -> [Tree e a] -> Tree e a
forall a b. (a -> b) -> a -> b
$ (Tree e a -> Tree e a) -> [Tree e a] -> [Tree e a]
forall a b. (a -> b) -> [a] -> [b]
map (Length -> Tree e a -> Tree e a
forall e a. HasLength e => Length -> Tree e a -> Tree e a
go Length
h'') [Tree e a]
ts