使用 Haskell 查找 LCS 的性能问题

如何解决使用 Haskell 查找 LCS 的性能问题

这是一个经典的编程问题https://en.wikipedia.org/wiki/Longest_common_subsequence_problem

JS 实现通过了所有测试，但 Haskell 实现了消耗过多内存并被杀死。

我做错了什么？

-- TOP TO BottOM
commonChild s1 s2 = L.foldl g l1 l ! n
    where
    n  = length s1
    l1 = arr $ replicate (n + 1) 0
    l  = [ [(x,i,y,j) | (y,j) <- zip s2 [1..]] 
           | (x,i) <- zip s1 [1..]]
    g a = L.foldl (\a' (x,j) -> let x' = if x == y
                                             then 1 + a ! (j - 1) 
                                             else max (a ! j) (a' ! (j - 1)) 
                                    in a' // [(j,x')]) 
                  l1

arr l = array (0,length l-1) $ zip [0..] l

function lcs(a,b) {
  let n = a.length
  let a1 = []
  for (let i = 0; i <= n; i++) {
    a1.push(0)
  }
  for (let i = 0; i < b.length; i++) {
    let a2 = [0]
    for (let j = 0; j < n; j++) {
      let x = b[i] == a[j] ? 1 + a1[j] : Math.max(a1[j+1],a2[j])
      a2.push(x)
    }
    a1 = a2
  }
  return a1[n]
}

console.log(lcs("SHINCHAN","NOHaraAA"))

https://repl.it/@leonbobster/LCS#main.hs

https://www.hackerrank.com/challenges/common-child/problem

解决方法

您对 // 中的 Data.Array 的使用真的会影响您的表现。如果您阅读 the docs，它会说“构造一个与第一个参数相同的数组，只是它已被正确参数中的关联更新”，这意味着每次调用它时，您都在构造一个全新的阵列。这与您的 js 实现非常不同，后者只是附加。

您可能认为数组是获得性能提升的明显选择，但这是常规旧列表可以正常工作的时候之一。与其在折叠的每次迭代中生成一个新数组，每个数组都比前一个元素多一个新元素，不如直接将其 cons 到一个列表中。考虑子函数 g 的以下定义：

g a = arr . reverse . L.foldl (inner a) [0]
inner a a'@(z:_) (x,i,y,j) =
  let x' = if x == y
            then 1 + a ! (j - 1)
            else max (a ! j) z
  in x':a'

注意：我上面所做的更改都是关于选择更好的数据结构，但请参阅@chi 的答案以了解更多提高性能的方法，这些方法与协商惰性/严格性和执行特定于 GHC 的工作有关东西。

我稍微修改了你的代码

添加类型签名
使用 foldl'
使用 bang 模式来强制严格
使用 -O2 编译（避免 GHCi）

这是修改后的代码（删除了长测试字符串）：

{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -Wall -O2 #-}
module Main where


import qualified Data.List as L 
import Data.Array

commonChild :: Eq a => [a] -> [a] -> Int
commonChild s1 s2 = L.foldl' g l1 l ! n
    where
        n = length s1
        l1 = arr $ replicate (n + 1) 0
        l = [[(x,j) | (y,j) <- zip s2 [1..]] | (x,i) <- zip s1 [(1::Int)..]]
        g a = L.foldl' (\ !a' (!x,!_i,!y,!j) -> let 
           ! x' = if x == y
               then 1 + a ! (j - 1) 
               else max (a ! j) (a' ! (j - 1)) in a' // [(j,x')]) l1 
 
arr :: [e] -> Array Int e
arr l = array (0,length l-1) $ zip [0..] l

s1test :: String
s1test = "UBBJXJGKLXGXTFBJ..." -- omitted

s2test :: String
s2test = "WZFPTGLCXK..." -- omitted

main :: IO ()
main = do
    print $ commonChild "SHINCHAN" "NOHARAAA"
    print $ commonChild s1test s2test

以上代码运行时使用的 RAM 不足 6MB，并在 3 分 10 秒内完成打印 3 和 1417 作为输出。

相比之下，当我终止时，原始代码使用了 12GB 以上的 RAM。

应该还有更多的改进空间。 Data.Array 中的数组可能很慢，因为每次数组更新都必须重新创建一个新数组。当命令式算法不能轻易转换成一个好的函数式算法时，也许最好暂时接受命令式的一面并开始使用 STUArray 及其相关函数，编写一些代码来精确地模仿您发布的命令式算法.使用runST，您仍然可以实现纯函数式接口并公开类似的类型

commonChild ::
   ( Eq a,forall s. MArray (STUArray s) a (ST s)    -- requires some extension
   ) => [a] -> [a] -> Int

（或者干脆放弃多态而使用 String -> String -> Int）。

阅读维基百科对该算法的描述，让我非常直接地实现了仅使用列表的实现；没有数组：

{-# LANGUAGE BangPatterns #-}

-- Calculate the next row from the character along the
-- left edge,the string along the top edge,and the previous
-- row.
makeRow :: Char -> String -> [Int] -> [Int]
makeRow match = go 0 0
  where
    -- The first arguments are the values in the arguments
    -- to the upper left and immediate left of the current
    -- cell.
    go :: Int -> Int -> Char -> String -> [Int] -> [Int]
    go !up_left !left (c:cs) (l:ls) =
      cur : go l cur cs ls
      where
        !cur
          | c == match = 1 + up_left
          | otherwise = max l left
    go _ _ _ _ = []

commonChild s1 = go (repeat (0 :: Int))
  where
    go ls [] = last ls
    go ls (c:cs) = go (makeRow c s1 ls) cs

这足够快，可以通过所有测试，而且比处理数组要简单得多。可以通过多种方式改进恒定因素，但这是一个很好的起点。我尝试改进的第一种方法是将 [Int] 到处都替换为类似于

data IntList = Cons !Int IntList | Nil

这为每个元素节省了两个字的内存和一个指针间接。在许多情况下，切换到未装箱数组（至少对于 Int 列表）应该会带来进一步的改进，但会更加烦人。

使用 Haskell 查找 LCS 的性能问题

如何解决使用 Haskell 查找 LCS 的性能问题

解决方法

相关推荐