DynamicTimeWarping.hs

module Data.Vector.DynamicTimeWarping where
import Control.Monad (forM_)
import qualified Data.Vector.Generic as V
import qualified Data.Array.ST as ST
import qualified Data.Array.MArray as MArray
import qualified Data.Array.Base as Arr

-- | Calculate the modification distance of two vectors.
--
-- The sequences don't need to be of equal length, multiple points of one
-- sequence can be matched to the same point of the other sequence. The matches
-- must be in order though.
distanceBy :: V.Vector v a => (a -> a -> Float) -> v a -> v a -> Float
distanceBy d left right
  | V.null left || V.null right = 1/0
  | otherwise =
    -- The algorithm is extremely simple in an imperative framework unless we
    -- carefully craft the memoization. Even then the mutable array is way
    -- faster.
    let lenl = V.length left
        lenr = V.length right
        def = 1/0
        tabl = ST.runSTUArray $ do
          table <- MArray.newArray_ ((0,0), (lenl, lenr))
          let write = MArray.writeArray table
              read_ = MArray.readArray table
          write (0,0) 0
          forM_ [1..lenl] $ \i -> write (i, 0) def
          forM_ [1..lenr] $ \j -> write (0, j) def
          forM_ [1..lenl] $ \i ->
            forM_ [1..lenr] $ \j -> do
              ins <- read_ (i-1,j)
              del <- read_ (i,j-1)
              mat <- read_ (i-1,j-1)
              let cost = d (left V.! (i-1)) (right V.! (j-1))
                  rec = ins `min` del `min` mat
              write (i,j) $ cost + rec
          return table
    in tabl Arr.! (lenl, lenr)