{-# LANGUAGE BangPatterns, FlexibleContexts #-}

-- | Implementations that are optimal in space and time.
module Data.Clustering.Hierarchical.Internal.Optimal
    ( singleLinkage
    , completeLinkage
    ) where

-- from base
import Prelude hiding (pi)
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Monad (forM_, liftM3, when)
import Control.Monad.ST (ST, runST)
import Data.Array (Array, listArray, (!))
import Data.Array.ST (STUArray, newArray_, newListArray,
                      readArray, writeArray,
                      getElems, getBounds) -- getAssocs
import Data.List (sortBy)
import Data.Maybe (fromMaybe)

-- from containers
import qualified Data.IntMap as IM

-- from this package
import Data.Clustering.Hierarchical.Internal.Types


mkErr :: String -> a
mkErr :: String -> a
mkErr = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("Data.Clustering.Hierarchical.Internal.Optimal." String -> String -> String
forall a. [a] -> [a] -> [a]
++)


type Index = Int

data PointerRepresentation s a =
  PR { PointerRepresentation s a -> STUArray s Index Index
pi     :: {-# UNPACK #-} !(STUArray s Index Index)
     , PointerRepresentation s a -> STUArray s Index Distance
lambda :: {-# UNPACK #-} !(STUArray s Index Distance)
     , PointerRepresentation s a -> STUArray s Index Distance
em     :: {-# UNPACK #-} !(STUArray s Index Distance)
     , PointerRepresentation s a -> Array Index a
elm    :: {-# UNPACK #-} !(Array Index a)
     }

-- debugPR :: Show a => PointerRepresentation s a -> ST s String
-- debugPR pr = do
--   pis     <- getAssocs (pi pr)
--   lambdas <- getAssocs (lambda pr)
--   ems     <- getAssocs (em pr)
--   return $ unlines [ "pi     = " ++ show pis
--                    , "lambda = " ++ show lambdas
--                    , "em     = " ++ show ems
--                    , "elm    = " ++ show (elm pr)
--                    ]

initPR :: Index -> Array Index a -> ST s (PointerRepresentation s a)
initPR :: Index -> Array Index a -> ST s (PointerRepresentation s a)
initPR n :: Index
n xs' :: Array Index a
xs' = ((Array Index a -> PointerRepresentation s a)
-> Array Index a -> PointerRepresentation s a
forall a b. (a -> b) -> a -> b
$ Array Index a
xs') ((Array Index a -> PointerRepresentation s a)
 -> PointerRepresentation s a)
-> ST s (Array Index a -> PointerRepresentation s a)
-> ST s (PointerRepresentation s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (STUArray s Index Index
 -> STUArray s Index Distance
 -> STUArray s Index Distance
 -> Array Index a
 -> PointerRepresentation s a)
-> ST s (STUArray s Index Index)
-> ST s (STUArray s Index Distance)
-> ST s (STUArray s Index Distance)
-> ST s (Array Index a -> PointerRepresentation s a)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 STUArray s Index Index
-> STUArray s Index Distance
-> STUArray s Index Distance
-> Array Index a
-> PointerRepresentation s a
forall s a.
STUArray s Index Index
-> STUArray s Index Distance
-> STUArray s Index Distance
-> Array Index a
-> PointerRepresentation s a
PR ((Index, Index) -> ST s (STUArray s Index Index)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (1, Index
n)) ((Index, Index) -> ST s (STUArray s Index Distance)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (1, Index
n)) ((Index, Index) -> ST s (STUArray s Index Distance)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (1, Index
n))

indexDistance :: [a] -> (a -> a -> Distance)
              -> (Index, Array Index a, Index -> Index -> Distance)
indexDistance :: [a]
-> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
indexDistance xs :: [a]
xs dist :: a -> a -> Distance
dist = (Index
n, Array Index a
xs', Index -> Index -> Distance
dist')
    where
      !n :: Index
n = [a] -> Index
forall (t :: * -> *) a. Foldable t => t a -> Index
length [a]
xs
      !xs' :: Array Index a
xs' = (Index, Index) -> [a] -> Array Index a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (1, Index
n) [a]
xs
      dist' :: Index -> Index -> Distance
dist' i :: Index
i j :: Index
j = a -> a -> Distance
dist (Array Index a
xs' Array Index a -> Index -> a
forall i e. Ix i => Array i e -> i -> e
! Index
i) (Array Index a
xs' Array Index a -> Index -> a
forall i e. Ix i => Array i e -> i -> e
! Index
j)


infinity :: Distance
infinity :: Distance
infinity = 1 Distance -> Distance -> Distance
forall a. Fractional a => a -> a -> a
/ 0


-- | /O(n^2)/ time and /O(n)/ space.  See 'singleLinkage' on this module.
slink :: [a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
slink :: [a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
slink xs :: [a]
xs dist :: a -> a -> Distance
dist = Index -> Array Index a -> ST s (PointerRepresentation s a)
forall a s.
Index -> Array Index a -> ST s (PointerRepresentation s a)
initPR Index
n Array Index a
xs' ST s (PointerRepresentation s a)
-> (PointerRepresentation s a -> ST s (PointerRepresentation s a))
-> ST s (PointerRepresentation s a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Index
-> PointerRepresentation s a -> ST s (PointerRepresentation s a)
forall (m :: * -> *) s a.
(MArray (STUArray s) Index m, MArray (STUArray s) Distance m) =>
Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go 1
    where
      (n :: Index
n, xs' :: Array Index a
xs', dist' :: Index -> Index -> Distance
dist') = [a]
-> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
forall a.
[a]
-> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
indexDistance [a]
xs a -> a -> Distance
dist

      go :: Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go !Index
i !PointerRepresentation s a
pr | Index
i Index -> Index -> Bool
forall a. Eq a => a -> a -> Bool
== Index
n Index -> Index -> Index
forall a. Num a => a -> a -> a
+ 1 = PointerRepresentation s a -> m (PointerRepresentation s a)
forall (m :: * -> *) a. Monad m => a -> m a
return PointerRepresentation s a
pr
                | Bool
otherwise  = do
        STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
i Index
i
        STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
i Distance
infinity
        [Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \j :: Index
j ->
          STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
j (Index -> Index -> Distance
dist' Index
j Index
i)
        [Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \j :: Index
j -> do
          Distance
lambda_j <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
j
          Distance
em_j     <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
j
          Index
pi_j     <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
j
          Distance
em_pi_j  <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
pi_j
          if Distance
lambda_j Distance -> Distance -> Bool
forall a. Ord a => a -> a -> Bool
>= Distance
em_j then do
            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
pi_j (Distance
em_pi_j Distance -> Distance -> Distance
forall a. Ord a => a -> a -> a
`min` Distance
lambda_j)
            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
j    Distance
em_j
            STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
j    Index
i
           else
            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
pi_j (Distance
em_pi_j Distance -> Distance -> Distance
forall a. Ord a => a -> a -> a
`min` Distance
em_j)
        [Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \j :: Index
j -> do
          Index
pi_j        <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
j
          Distance
lambda_j    <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
j
          Distance
lambda_pi_j <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
pi_j
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Distance
lambda_j Distance -> Distance -> Bool
forall a. Ord a => a -> a -> Bool
>= Distance
lambda_pi_j) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr) Index
j Index
i
        Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
+1) PointerRepresentation s a
pr


-- | /O(n^2)/ time and /O(n)/ space. See 'completeLinkage' on this module.
clink :: [a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
clink :: [a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
clink xs :: [a]
xs dist :: a -> a -> Distance
dist = Index -> Array Index a -> ST s (PointerRepresentation s a)
forall a s.
Index -> Array Index a -> ST s (PointerRepresentation s a)
initPR Index
n Array Index a
xs' ST s (PointerRepresentation s a)
-> (PointerRepresentation s a -> ST s (PointerRepresentation s a))
-> ST s (PointerRepresentation s a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Index
-> PointerRepresentation s a -> ST s (PointerRepresentation s a)
forall (m :: * -> *) s a.
(MArray (STUArray s) Index m, MArray (STUArray s) Distance m) =>
Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go 1
    where
      (n :: Index
n, xs' :: Array Index a
xs', dist' :: Index -> Index -> Distance
dist') = [a]
-> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
forall a.
[a]
-> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
indexDistance [a]
xs a -> a -> Distance
dist

      go :: Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go !Index
i !PointerRepresentation s a
pr | Index
i Index -> Index -> Bool
forall a. Eq a => a -> a -> Bool
== Index
n Index -> Index -> Index
forall a. Num a => a -> a -> a
+ 1 = PointerRepresentation s a -> m (PointerRepresentation s a)
forall (m :: * -> *) a. Monad m => a -> m a
return PointerRepresentation s a
pr
                | Index
i Index -> Index -> Bool
forall a. Eq a => a -> a -> Bool
== 1     = do STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     1 1
                                  STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) 1 Distance
infinity
                                  Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go 2 PointerRepresentation s a
pr
                | Bool
otherwise  = do
        -- First part
        STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
i Index
i
        STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
i Distance
infinity
        [Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \j :: Index
j ->
          STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
j (Index -> Index -> Distance
dist' Index
j Index
i)
        [Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \j :: Index
j -> do
          Distance
lambda_j <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
j
          Distance
em_j     <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
j
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Distance
lambda_j Distance -> Distance -> Bool
forall a. Ord a => a -> a -> Bool
< Distance
em_j) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Index
pi_j     <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
j
            Distance
em_pi_j  <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
pi_j
            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
pi_j (Distance
em_pi_j Distance -> Distance -> Distance
forall a. Ord a => a -> a -> a
`max` Distance
em_j)
            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
j    Distance
infinity

        -- Loop a
        Index
a <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1) m Distance -> (Distance -> m Index) -> m Index
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Index -> PointerRepresentation s a -> Index -> Distance -> m Index
forall (m :: * -> *) s a.
(MArray (STUArray s) Index m, MArray (STUArray s) Distance m) =>
Index -> PointerRepresentation s a -> Index -> Distance -> m Index
go_a_loop (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1) PointerRepresentation s a
pr (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1)

        -- Loop b
        Index
b <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
a
        Distance
c <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
a
        STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
a Index
i
        STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
a (Distance -> m ()) -> m Distance -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
a
        Index
-> PointerRepresentation s a -> Index -> Index -> Distance -> m ()
forall (m :: * -> *) s a.
(MArray (STUArray s) Index m, MArray (STUArray s) Distance m) =>
Index
-> PointerRepresentation s a -> Index -> Index -> Distance -> m ()
go_b_loop Index
i PointerRepresentation s a
pr Index
a Index
b Distance
c

        -- Final part
        [Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \j :: Index
j -> do
          Index
pi_j    <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr) Index
j
          Index
pi_pi_j <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr) Index
pi_j
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Index
pi_pi_j Index -> Index -> Bool
forall a. Eq a => a -> a -> Bool
== Index
i) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Distance
lambda_j    <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
j
            Distance
lambda_pi_j <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
pi_j
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Distance
lambda_j Distance -> Distance -> Bool
forall a. Ord a => a -> a -> Bool
>= Distance
lambda_pi_j) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr) Index
j Index
i

        -- Recurse
        Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
+1) PointerRepresentation s a
pr

      -- Loop a's core
      go_a_loop :: Index -> PointerRepresentation s a -> Index -> Distance -> m Index
go_a_loop 0 _ a :: Index
a _ = Index -> m Index
forall (m :: * -> *) a. Monad m => a -> m a
return Index
a
      go_a_loop !Index
j !PointerRepresentation s a
pr !Index
a !Distance
em_a = do
        Index
pi_j     <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
j
        Distance
lambda_j <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
j
        Distance
em_pi_j  <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr)     Index
pi_j
        if Distance
lambda_j Distance -> Distance -> Bool
forall a. Ord a => a -> a -> Bool
>= Distance
em_pi_j then do
          Distance
em_j <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
j
          if Distance
em_j Distance -> Distance -> Bool
forall a. Ord a => a -> a -> Bool
< Distance
em_a then
            Index -> PointerRepresentation s a -> Index -> Distance -> m Index
go_a_loop (Index
jIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1) PointerRepresentation s a
pr Index
j Distance
em_j
           else
            Index -> PointerRepresentation s a -> Index -> Distance -> m Index
go_a_loop (Index
jIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1) PointerRepresentation s a
pr Index
a Distance
em_a
         else do
          STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
em PointerRepresentation s a
pr) Index
j Distance
infinity
          Index -> PointerRepresentation s a -> Index -> Distance -> m Index
go_a_loop (Index
jIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1) PointerRepresentation s a
pr Index
a Distance
em_a

      -- Loop b's core
      go_b_loop :: Index
-> PointerRepresentation s a -> Index -> Index -> Distance -> m ()
go_b_loop !Index
i !PointerRepresentation s a
pr !Index
a !Index
b !Distance
c
          | Index
a Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
>= Index
i Index -> Index -> Index
forall a. Num a => a -> a -> a
- 1 = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | Index
b Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
<  Index
i Index -> Index -> Index
forall a. Num a => a -> a -> a
- 1 = do Index
pi_b     <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
b
                            Distance
lambda_b <- STUArray s Index Distance -> Index -> m Distance
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
b
                            STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
b Index
i
                            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
b Distance
c
                            Index
-> PointerRepresentation s a -> Index -> Index -> Distance -> m ()
go_b_loop Index
i PointerRepresentation s a
pr Index
a Index
pi_b Distance
lambda_b
          | Bool
otherwise  = do STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)     Index
b Index
i
                            STUArray s Index Distance -> Index -> Distance -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr) Index
b Distance
c
                            () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | /O(n log n)/ time and /O(n)/ space. Construct a 'Dendrogram'
-- from a 'PointerRepresentation'.
buildDendrogram :: PointerRepresentation s a
                -> ST s (Dendrogram a)
buildDendrogram :: PointerRepresentation s a -> ST s (Dendrogram a)
buildDendrogram pr :: PointerRepresentation s a
pr = do
  (1,n :: Index
n) <- STUArray s Index Distance -> ST s (Index, Index)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr)
  [Distance]
lambdas <- STUArray s Index Distance -> ST s [Distance]
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m [e]
getElems (PointerRepresentation s a -> STUArray s Index Distance
forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda PointerRepresentation s a
pr)
  [Index]
pis     <- STUArray s Index Index -> ST s [Index]
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m [e]
getElems (PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr)
  let sorted :: [(Index, Distance, Index)]
sorted = ((Index, Distance, Index) -> (Index, Distance, Index) -> Ordering)
-> [(Index, Distance, Index)] -> [(Index, Distance, Index)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(_,l1 :: Distance
l1,_) (_,l2 :: Distance
l2,_) -> Distance
l1 Distance -> Distance -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Distance
l2) ([(Index, Distance, Index)] -> [(Index, Distance, Index)])
-> [(Index, Distance, Index)] -> [(Index, Distance, Index)]
forall a b. (a -> b) -> a -> b
$
               [Index] -> [Distance] -> [Index] -> [(Index, Distance, Index)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [1..] [Distance]
lambdas [Index]
pis
  STUArray s Index Index
index <- (Index, Index) -> [Index] -> ST s (STUArray s Index Index)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (1,Index
n) [1..]
  let go :: IntMap (Dendrogram a)
-> [(Index, (Index, Distance, Index))] -> m (Dendrogram a)
go im :: IntMap (Dendrogram a)
im [] =
        case IntMap (Dendrogram a) -> [(Index, Dendrogram a)]
forall a. IntMap a -> [(Index, a)]
IM.toList IntMap (Dendrogram a)
im of
          [(_,x :: Dendrogram a
x)] -> Dendrogram a -> m (Dendrogram a)
forall (m :: * -> *) a. Monad m => a -> m a
return Dendrogram a
x
          _       -> String -> m (Dendrogram a)
forall a. String -> a
mkErr "buildDendrogram: final never here"
      go im :: IntMap (Dendrogram a)
im ((i :: Index
i, (j :: Index
j,lambda_j :: Distance
lambda_j,pi_j :: Index
pi_j)):rest :: [(Index, (Index, Distance, Index))]
rest) = do
        Index
left_i  <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Index Index
index Index
j
        Index
right_i <- STUArray s Index Index -> Index -> m Index
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Index Index
index Index
pi_j
        STUArray s Index Index -> Index -> Index -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (STUArray s Index Index
index STUArray s Index Index
-> STUArray s Index Index -> STUArray s Index Index
forall a. a -> a -> a
`asTypeOf` PointerRepresentation s a -> STUArray s Index Index
forall s a. PointerRepresentation s a -> STUArray s Index Index
pi PointerRepresentation s a
pr) Index
pi_j (Index -> Index
forall a. Num a => a -> a
negate Index
i)
        let (left :: Dendrogram a
left,  im' :: IntMap (Dendrogram a)
im')  | Index
left_i Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
> 0  = (a -> Dendrogram a
forall a. a -> Dendrogram a
Leaf (a -> Dendrogram a) -> a -> Dendrogram a
forall a b. (a -> b) -> a -> b
$ PointerRepresentation s a -> Array Index a
forall s a. PointerRepresentation s a -> Array Index a
elm PointerRepresentation s a
pr Array Index a -> Index -> a
forall i e. Ix i => Array i e -> i -> e
! Index
left_i, IntMap (Dendrogram a)
im)
                          | Bool
otherwise   = (Maybe (Dendrogram a) -> Dendrogram a)
-> (Maybe (Dendrogram a), IntMap (Dendrogram a))
-> (Dendrogram a, IntMap (Dendrogram a))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Dendrogram a -> Maybe (Dendrogram a) -> Dendrogram a
forall a. a -> Maybe a -> a
fromMaybe Dendrogram a
forall a. a
e1) ((Maybe (Dendrogram a), IntMap (Dendrogram a))
 -> (Dendrogram a, IntMap (Dendrogram a)))
-> (Maybe (Dendrogram a), IntMap (Dendrogram a))
-> (Dendrogram a, IntMap (Dendrogram a))
forall a b. (a -> b) -> a -> b
$
                                          (Index -> Dendrogram a -> Maybe (Dendrogram a))
-> Index
-> IntMap (Dendrogram a)
-> (Maybe (Dendrogram a), IntMap (Dendrogram a))
forall a.
(Index -> a -> Maybe a) -> Index -> IntMap a -> (Maybe a, IntMap a)
IM.updateLookupWithKey (\_ _ -> Maybe (Dendrogram a)
forall a. Maybe a
Nothing) Index
ix IntMap (Dendrogram a)
im
                          where ix :: Index
ix = Index -> Index
forall a. Num a => a -> a
negate Index
left_i
            (right :: Dendrogram a
right, im'' :: IntMap (Dendrogram a)
im'') | Index
right_i Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = (a -> Dendrogram a
forall a. a -> Dendrogram a
Leaf (a -> Dendrogram a) -> a -> Dendrogram a
forall a b. (a -> b) -> a -> b
$ PointerRepresentation s a -> Array Index a
forall s a. PointerRepresentation s a -> Array Index a
elm PointerRepresentation s a
pr Array Index a -> Index -> a
forall i e. Ix i => Array i e -> i -> e
! Index
right_i, IntMap (Dendrogram a)
im')
                          | Bool
otherwise   = (Maybe (Dendrogram a) -> Dendrogram a)
-> (Maybe (Dendrogram a), IntMap (Dendrogram a))
-> (Dendrogram a, IntMap (Dendrogram a))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Dendrogram a -> Maybe (Dendrogram a) -> Dendrogram a
forall a. a -> Maybe a -> a
fromMaybe Dendrogram a
forall a. a
e2) ((Maybe (Dendrogram a), IntMap (Dendrogram a))
 -> (Dendrogram a, IntMap (Dendrogram a)))
-> (Maybe (Dendrogram a), IntMap (Dendrogram a))
-> (Dendrogram a, IntMap (Dendrogram a))
forall a b. (a -> b) -> a -> b
$
                                          (Index -> Dendrogram a -> Maybe (Dendrogram a))
-> Index
-> IntMap (Dendrogram a)
-> (Maybe (Dendrogram a), IntMap (Dendrogram a))
forall a.
(Index -> a -> Maybe a) -> Index -> IntMap a -> (Maybe a, IntMap a)
IM.updateLookupWithKey (\_ _ -> Maybe (Dendrogram a)
forall a. Maybe a
Nothing) Index
ix IntMap (Dendrogram a)
im'
                          where ix :: Index
ix = Index -> Index
forall a. Num a => a -> a
negate Index
right_i
            im''' :: IntMap (Dendrogram a)
im''' = Index
-> Dendrogram a -> IntMap (Dendrogram a) -> IntMap (Dendrogram a)
forall a. Index -> a -> IntMap a -> IntMap a
IM.insert Index
i (Distance -> Dendrogram a -> Dendrogram a -> Dendrogram a
forall a. Distance -> Dendrogram a -> Dendrogram a -> Dendrogram a
Branch Distance
lambda_j Dendrogram a
left Dendrogram a
right) IntMap (Dendrogram a)
im''
            e1 :: a
e1 = String -> a
forall a. String -> a
mkErr "buildDendrogram: never here 1"
            e2 :: a
e2 = String -> a
forall a. String -> a
mkErr "buildDendrogram: never here 2"
        IntMap (Dendrogram a)
-> [(Index, (Index, Distance, Index))] -> m (Dendrogram a)
go IntMap (Dendrogram a)
im''' [(Index, (Index, Distance, Index))]
rest
  IntMap (Dendrogram a)
-> [(Index, (Index, Distance, Index))] -> ST s (Dendrogram a)
forall (m :: * -> *).
MArray (STUArray s) Index m =>
IntMap (Dendrogram a)
-> [(Index, (Index, Distance, Index))] -> m (Dendrogram a)
go IntMap (Dendrogram a)
forall a. IntMap a
IM.empty ([Index]
-> [(Index, Distance, Index)]
-> [(Index, (Index, Distance, Index))]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..Index
nIndex -> Index -> Index
forall a. Num a => a -> a -> a
-1] [(Index, Distance, Index)]
sorted)


-- | /O(n^2)/ time and /O(n)/ space. Calculates a complete,
-- rooted dendrogram for a list of items using single linkage
-- with the SLINK algorithm.  This algorithm is optimal in space
-- and time.
--
-- [Reference] R. Sibson (1973). \"SLINK: an optimally efficient
--   algorithm for the single-link cluster method\". /The/
--   /Computer Journal/ (British Computer Society) 16 (1):
--   30-34.
singleLinkage :: [a] -> (a -> a -> Distance) -> Dendrogram a
singleLinkage :: [a] -> (a -> a -> Distance) -> Dendrogram a
singleLinkage []  _   = String -> Dendrogram a
forall a. String -> a
mkErr "singleLinkage: empty input"
singleLinkage [x :: a
x] _   = a -> Dendrogram a
forall a. a -> Dendrogram a
Leaf a
x
singleLinkage xs :: [a]
xs dist :: a -> a -> Distance
dist = (forall s. ST s (Dendrogram a)) -> Dendrogram a
forall a. (forall s. ST s a) -> a
runST ([a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
forall a s.
[a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
slink [a]
xs a -> a -> Distance
dist ST s (PointerRepresentation s a)
-> (PointerRepresentation s a -> ST s (Dendrogram a))
-> ST s (Dendrogram a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PointerRepresentation s a -> ST s (Dendrogram a)
forall s a. PointerRepresentation s a -> ST s (Dendrogram a)
buildDendrogram)


-- | /O(n^2)/ time and /O(n)/ space. Calculates a complete, rooted dendrogram for a list
-- of items using complete linkage with the CLINK algorithm.  This
-- algorithm is optimal in space and time.
--
-- [Reference] D. Defays (1977). \"An efficient algorithm for a
--   complete link method\". /The Computer Journal/ (British
--   Computer Society) 20 (4): 364-366.
completeLinkage :: [a] -> (a -> a -> Distance) -> Dendrogram a
completeLinkage :: [a] -> (a -> a -> Distance) -> Dendrogram a
completeLinkage []  _   = String -> Dendrogram a
forall a. String -> a
mkErr "completeLinkage: empty input"
completeLinkage [x :: a
x] _   = a -> Dendrogram a
forall a. a -> Dendrogram a
Leaf a
x
completeLinkage xs :: [a]
xs dist :: a -> a -> Distance
dist = (forall s. ST s (Dendrogram a)) -> Dendrogram a
forall a. (forall s. ST s a) -> a
runST ([a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
forall a s.
[a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
clink [a]
xs a -> a -> Distance
dist ST s (PointerRepresentation s a)
-> (PointerRepresentation s a -> ST s (Dendrogram a))
-> ST s (Dendrogram a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PointerRepresentation s a -> ST s (Dendrogram a)
forall s a. PointerRepresentation s a -> ST s (Dendrogram a)
buildDendrogram)