如何在 Haskell 中高效生成所有交错列表？

Question

在 Haskell 中生成通过交错给定列表列表的元素获得的所有列表的最有效方法是什么？

https://stackoverflow.com/a/41929156提出以下代码：

interleavings :: [[a]] -> [[a]]
interleavings = go . filter (not . null)
  where
    go [] = [[]]
    go xss = do
      (xssl, x : xs, xssr) <- zippers xss
      (x :) <$> interleavings ([xs | not (null xs)] ++ xssl ++ xssr)
    zippers :: [a] -> [([a], a, [a])]
    zippers = go' []
      where
        go' l (h : r) = (l, h, r) : go' (h : l) r
        go' _ [] = []

ghci> interleavings [[1,2,3],[4,5],[6]]
[[1,2,3,4,5,6],[1,2,3,4,6,5],[1,2,3,6,4,5],[1,2,4,5,3,6],[1,2,4,5,6,3],[1,2,4,3,5,6],[1,2,4,3,6,5],[1,2,4,6,3,5],[1,2,4,6,5,3],[1,2,6,4,5,3],[1,2,6,4,3,5],[1,2,6,3,4,5],[1,4,5,2,3,6],[1,4,5,2,6,3],[1,4,5,6,2,3],[1,4,2,3,5,6],[1,4,2,3,6,5],[1,4,2,5,3,6],[1,4,2,5,6,3],[1,4,2,6,5,3],[1,4,2,6,3,5],[1,4,6,2,3,5],[1,4,6,2,5,3],[1,4,6,5,2,3],[1,6,4,5,2,3],[1,6,4,2,3,5],[1,6,4,2,5,3],[1,6,2,3,4,5],[1,6,2,4,5,3],[1,6,2,4,3,5],[4,5,1,2,3,6],[4,5,1,2,6,3],[4,5,1,6,2,3],[4,5,6,1,2,3],[4,1,2,3,5,6],[4,1,2,3,6,5],[4,1,2,5,3,6],[4,1,2,5,6,3],[4,1,2,6,5,3],[4,1,2,6,3,5],[4,1,5,2,3,6],[4,1,5,2,6,3],[4,1,5,6,2,3],[4,1,6,5,2,3],[4,1,6,2,3,5],[4,1,6,2,5,3],[4,6,1,2,3,5],[4,6,1,2,5,3],[4,6,1,5,2,3],[4,6,5,1,2,3],[6,4,5,1,2,3],[6,4,1,2,3,5],[6,4,1,2,5,3],[6,4,1,5,2,3],[6,1,2,3,4,5],[6,1,2,4,5,3],[6,1,2,4,3,5],[6,1,4,5,2,3],[6,1,4,2,3,5],[6,1,4,2,5,3]]

这对于尝试程序指令的所有交错的并发测试很有用。

但是考虑到 Haskell 的惰性求值以及我们使用单链表的事实，是否有更有效的方法来做到这一点？如果我们不需要同时将整个结果存储在内存中，而是只需要在每个交错上计算一个函数怎么办？

Answer 1

通过使用原始数组，您可以稍微加快速度（在我的测试中为 33%）：

import Data.Primitive.SmallArray
import Data.Primitive.PrimArray
import Data.Primitive (Prim)
import Control.Monad

smallToPrim :: Prim b => (a -> b) -> SmallArray a -> PrimArray b
smallToPrim f xs = runPrimArray $ do
  let n = length xs
  s <- newPrimArray n
  let
    go i 
      | i < n = do
        writePrimArray s i (f (indexSmallArray xs i))
        go (i + 1)
      | otherwise = pure ()
  go 0
  pure s

decrement :: Int -> PrimArray Int -> PrimArray Int
decrement i xs = runPrimArray $ do
  let n = sizeofPrimArray xs
  s <- newPrimArray n
  copyPrimArray s 0 xs 0 n
  x <- readPrimArray s i
  writePrimArray s i (x - 1)
  return s

interleavings :: SmallArray (SmallArray a) -> [[a]]
interleavings xs0 = go [] (smallToPrim length xs0) where
  n = length xs0
  zeros = runPrimArray $ do s <- newPrimArray n; setPrimArray s 0 n 0; pure s
  go acc xs
    | xs == zeros = [acc] 
    | otherwise = concatMap (\i -> guard (indexPrimArray xs i > 0) *> go (indexSmallArray (indexSmallArray xs0 i) (indexPrimArray xs i - 1) : acc) (decrement i xs)) [0 .. n - 1]

main :: IO ()
main = print $ length $ interleavings $ smallArrayFromList $ map smallArrayFromList $ replicate 4 [1 :: Int .. 4]