{-# LANGUAGE BangPatterns, FlexibleContexts #-}
module Data.Clustering.Hierarchical.Internal.Optimal
( singleLinkage
, completeLinkage
) where
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)
import Data.List (sortBy)
import Data.Maybe (fromMaybe)
import qualified Data.IntMap as IM
import Data.Clustering.Hierarchical.Internal.Types
mkErr :: String -> a
mkErr :: forall a. 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
. (String
"Data.Clustering.Hierarchical.Internal.Optimal." String -> String -> String
forall a. [a] -> [a] -> [a]
++)
type Index = Int
data PointerRepresentation s a =
PR { forall s a. PointerRepresentation s a -> STUArray s Index Index
pi :: {-# UNPACK #-} !(STUArray s Index Index)
, forall s a. PointerRepresentation s a -> STUArray s Index Distance
lambda :: {-# UNPACK #-} !(STUArray s Index Distance)
, forall s a. PointerRepresentation s a -> STUArray s Index Distance
em :: {-# UNPACK #-} !(STUArray s Index Distance)
, forall s a. PointerRepresentation s a -> Array Index a
elm :: {-# UNPACK #-} !(Array Index a)
}
initPR :: Index -> Array Index a -> ST s (PointerRepresentation s a)
initPR :: forall a s.
Index -> Array Index a -> ST s (PointerRepresentation s a)
initPR Index
n 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_ (Index
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_ (Index
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_ (Index
1, Index
n))
indexDistance :: [a] -> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
indexDistance :: forall a.
[a]
-> (a -> a -> Distance)
-> (Index, Array Index a, Index -> Index -> Distance)
indexDistance [a]
xs 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 (Index
1, Index
n) [a]
xs
dist' :: Index -> Index -> Distance
dist' Index
i 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 = Distance
1 Distance -> Distance -> Distance
forall a. Fractional a => a -> a -> a
/ Distance
0
slink :: [a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
slink :: forall a s.
[a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
slink [a]
xs 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 Index
1
where
(Index
n, Array Index a
xs', 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
+ Index
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_ [Index
1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \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_ [Index
1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \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_ [Index
1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \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
+Index
1) PointerRepresentation s a
pr
clink :: [a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
clink :: forall a s.
[a] -> (a -> a -> Distance) -> ST s (PointerRepresentation s a)
clink [a]
xs 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 Index
1
where
(Index
n, Array Index a
xs', 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
+ Index
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
== Index
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) Index
1 Index
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) Index
1 Distance
infinity
Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go Index
2 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_ [Index
1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \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_ [Index
1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \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
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
-Index
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
-Index
1) PointerRepresentation s a
pr (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1)
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
[Index] -> (Index -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Index
1..Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] ((Index -> m ()) -> m ()) -> (Index -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \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
Index -> PointerRepresentation s a -> m (PointerRepresentation s a)
go (Index
iIndex -> Index -> Index
forall a. Num a => a -> a -> a
+Index
1) PointerRepresentation s a
pr
go_a_loop :: Index -> PointerRepresentation s a -> Index -> Distance -> m Index
go_a_loop Index
0 PointerRepresentation s a
_ Index
a Distance
_ = 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
-Index
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
-Index
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
-Index
1) PointerRepresentation s a
pr Index
a Distance
em_a
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
- Index
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
- Index
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 ()
buildDendrogram :: PointerRepresentation s a
-> ST s (Dendrogram a)
buildDendrogram :: forall s a. PointerRepresentation s a -> ST s (Dendrogram a)
buildDendrogram PointerRepresentation s a
pr = do
(Index
1,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 (\(Index
_,Distance
l1,Index
_) (Index
_,Distance
l2,Index
_) -> 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 [Index
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 (Index
1,Index
n) [Index
1..]
let go :: IntMap (Dendrogram a)
-> [(Index, (Index, Distance, Index))] -> m (Dendrogram a)
go IntMap (Dendrogram a)
im [] =
case IntMap (Dendrogram a) -> [(Index, Dendrogram a)]
forall a. IntMap a -> [(Index, a)]
IM.toList IntMap (Dendrogram a)
im of
[(Index
_,Dendrogram a
x)] -> Dendrogram a -> m (Dendrogram a)
forall (m :: * -> *) a. Monad m => a -> m a
return Dendrogram a
x
[(Index, Dendrogram a)]
_ -> String -> m (Dendrogram a)
forall a. String -> a
mkErr String
"buildDendrogram: final never here"
go IntMap (Dendrogram a)
im ((Index
i, (Index
j,Distance
lambda_j,Index
pi_j)):[(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 (Dendrogram a
left, IntMap (Dendrogram a)
im') | Index
left_i Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
> Index
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 (\Index
_ Dendrogram a
_ -> 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
(Dendrogram a
right, IntMap (Dendrogram a)
im'') | Index
right_i Index -> Index -> Bool
forall a. Ord a => a -> a -> Bool
> Index
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 (\Index
_ Dendrogram a
_ -> 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 String
"buildDendrogram: never here 1"
e2 :: a
e2 = String -> a
forall a. String -> a
mkErr String
"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 [Index
1..Index
nIndex -> Index -> Index
forall a. Num a => a -> a -> a
-Index
1] [(Index, Distance, Index)]
sorted)
singleLinkage :: [a] -> (a -> a -> Distance) -> Dendrogram a
singleLinkage :: forall a. [a] -> (a -> a -> Distance) -> Dendrogram a
singleLinkage [] a -> a -> Distance
_ = String -> Dendrogram a
forall a. String -> a
mkErr String
"singleLinkage: empty input"
singleLinkage [a
x] a -> a -> Distance
_ = a -> Dendrogram a
forall a. a -> Dendrogram a
Leaf a
x
singleLinkage [a]
xs 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)
completeLinkage :: [a] -> (a -> a -> Distance) -> Dendrogram a
completeLinkage :: forall a. [a] -> (a -> a -> Distance) -> Dendrogram a
completeLinkage [] a -> a -> Distance
_ = String -> Dendrogram a
forall a. String -> a
mkErr String
"completeLinkage: empty input"
completeLinkage [a
x] a -> a -> Distance
_ = a -> Dendrogram a
forall a. a -> Dendrogram a
Leaf a
x
completeLinkage [a]
xs 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)