Strings distance count algorithms from Stanford NLP course.

algorithms.hs

import Control.Arrow ((***), second)
import Data.Array
import Data.Function (on)
import Data.List (minimumBy)

data Action = Ins
            | Del
            | Sub
            | Id
              deriving Show

levenstein :: String -> String -> (Int, [Action])
levenstein x y = second reverse $ ds ! (length x, length y)
  where ds :: Array (Int, Int) (Int, [Action])
        ds = array ((0, 0), (length x, length y)) [((i, j), d i j) | i <- [0..length x], j <- [0..length y]]

        d :: Int -> Int -> (Int, [Action])
        d i 0 = (i, replicate i Ins)
        d 0 j = (j, replicate j Del)
        d i j = minimumBy (compare `on` fst)
                  [ ins (ds ! (i-1, j))
                  , del (ds ! (i, j-1))
                  , sub (ds ! (i-1, j-1))
                  ]
          where ins, del, sub :: (Int, [Action]) -> (Int, [Action])
                ins = let weight = 1
                      in (+ weight) *** (Ins:)
                del = let weight = 1
                      in (+ weight) *** (Del:)
                sub = let weight = 2
                      in case x !! (i-1) == y !! (j - 1) of
                           True  -> second (Id:)
                           False -> (+ weight) *** (Sub:)

needleman_wunsch :: String -> String -> Int
needleman_wunsch x y = max (maximum [d (length x) j | j <- [1..length y]]) (maximum [d i (length y) | i <- [1..length x]])
  where d :: Int -> Int -> Int
        d _ 0 = 0
        d 0 _ = 0
        d i j = maximum
                  [ d (i-1) j - w
                  , d i (j-1) - w
                  , d (i-1) (j-1) + s (x !! (i-1)) (y !! (j-1))
                  ]

        s :: Char -> Char -> Int
        s a b | a == b = 1 
              | otherwise = (-2) * w

        w :: Int
        w = 1

smith_waterman :: String -> String -> Int
smith_waterman x y = max (maximum [d (length x) j | j <- [1..length y]]) (maximum [d i (length y) | i <- [1..length x]])
  where d :: Int -> Int -> Int
        d _ 0 = 0
        d 0 _ = 0
        d i j = maximum
                  [ 0
                  , d (i-1) j - w
                  , d i (j-1) - w
                  , d (i-1) (j-1) + s (x !! (i-1)) (y !! (j-1))
                  ]

        s :: Char -> Char -> Int
        s a b | a == b = 1 
              | otherwise = (-2) * w

        w :: Int
        w = 1