交错两个字符串，保持顺序：函数式

Question

在this question，作者提出了一个有趣的编程问题：给定两个字符串，找出保留原始字符串顺序的那些可能的“交错”排列。

我将问题概括为n 字符串，而不是 OP 中的 2，并提出：

-- charCandidate is a function that finds possible character from given strings.
-- input : list of strings
-- output : a list of tuple, whose first value holds a character 
-- and second value holds the rest of strings with that character removed
-- i.e ["ab", "cd"] -> [('a', ["b", "cd"])] ..

charCandidate xs = charCandidate' xs []
charCandidate' :: [String] -> [String] -> [(Char, [String])]
charCandidate' [] _ = []     
charCandidate' ([]:xs) prev = 
    charCandidate' xs prev
charCandidate' (x@(c:rest):xs) prev =
    (c, prev ++ [rest] ++ xs) : charCandidate' xs (x:prev)

interleavings :: [String] -> [String]
interleavings xs = interleavings' xs []    

-- interleavings is a function that repeatedly applies 'charCandidate' function, to consume
-- the tuple and build permutations.
-- stops looping if there is no more tuple from charCandidate.

interleavings' :: [String] -> String -> [String]
interleavings' xs prev = 
    let candidates = charCandidate xs
        in case candidates of
            [] -> [prev]
            _  -> concat . map (\(char, ys) -> interleavings' ys (prev ++ [char])) $ candidates

-- test case
input :: [String]
input = ["ab", "cd"]    
-- interleavings input == ["abcd","acbd","acdb","cabd","cadb","cdab"]

它可以工作，但是我很关心代码：

1. 太丑了。没有积分！
2. 显式递归和附加函数参数prev 以保留状态
3. 使用元组作为中间形式

如何将上述程序重写为更“haskellic”、简洁、易读和更符合“函数式编程”？

Answer 1

我想我会这样写。主要思想是将创建交错视为一个不确定的过程，它选择一个输入字符串来开始交错和递归。

在我们开始之前，拥有一个我用过无数次的实用函数会很有帮助。它提供了一种从列表中选择元素并知道它是哪个元素的便捷方法。这有点像你的charCandidate'，只是它一次只对一个列表进行操作（因此适用范围更广）。

zippers :: [a] -> [([a], a, [a])]
zippers = go [] where
    go xs [] = []
    go xs (y:ys) = (xs, y, ys) : go (y:xs) ys

有了这些，使用 list monad 很容易做出一些不确定的选择。从概念上讲，我们的interleavings 函数可能应该有一个类似[NonEmpty a] -> [[a]] 的类型，它承诺每个传入的字符串中至少有一个字符，但是NonEmpty 的语法开销对于像这样的简单练习来说太烦人了，所以我们' 会在违反此前提条件时给出错误的答案。您还可以考虑将其设为辅助函数，并在运行此函数之前从您的顶级函数中过滤掉空列表。

interleavings :: [[a]] -> [[a]]
interleavings [] = [[]]
interleavings xss = do
    (xssL, h:xs, xssR) <- zippers xss
    t <- interleavings ([xs | not (null xs)] ++ xssL ++ xssR)
    return (h:t)

你可以在 ghci 中看到它：

> interleavings ["abc", "123"]
["abc123","ab123c","ab12c3","ab1c23","a123bc","a12bc3","a12b3c","a1bc23","a1b23c","a1b2c3","123abc","12abc3","12ab3c","12a3bc","1abc23","1ab23c","1ab2c3","1a23bc","1a2bc3","1a2b3c"]
> interleavings ["a", "b", "c"]
["abc","acb","bac","bca","cba","cab"]
> permutations "abc" -- just for fun, to compare
["abc","bac","cba","bca","cab","acb"]

Answer 2

这是迄今为止我提出的最快的实现。它成对地交错列表列表。

interleavings :: [[a]] -> [[a]]
interleavings = foldr (concatMap . interleave2) [[]]

这种可怕的丑陋混乱是我能找到的交错两个列表的最佳方法。它旨在渐近最优（我相信确实如此）；它不是很漂亮。可以通过使用专用队列（例如在Data.List 中用于实现inits 的队列）而不是序列来改进常量因素，但我不想包含那么多样板。

{-# LANGUAGE BangPatterns #-}
import Data.Monoid
import Data.Foldable (toList)
import Data.Sequence (Seq, (|>))

interleave2 :: [a] -> [a] -> [[a]]
interleave2 xs ys = interleave2' mempty xs ys []

interleave2' :: Seq a -> [a] -> [a] -> [[a]] -> [[a]]
interleave2' !prefix xs ys rest =
  (toList prefix ++ xs ++ ys)
     : interleave2'' prefix xs ys rest

interleave2'' :: Seq a -> [a] -> [a] -> [[a]] -> [[a]]
interleave2'' !prefix [] _ = id
interleave2'' !prefix _ [] = id
interleave2'' !prefix xs@(x : xs') ys@(y : ys') =
  interleave2' (prefix |> y) xs ys' .
      interleave2'' (prefix |> x) xs' ys

Answer 3

在 interleave2 上使用 foldr

interleave :: [[a]] -> [[a]]
interleave = foldr ((concat .) . map . iL2) [[]]  where 
   iL2 [] ys = [ys]
   iL2 xs [] = [xs]
   iL2 (x:xs) (y:ys) = map (x:) (iL2 xs (y:ys)) ++ map (y:) (iL2 (x:xs) ys)

Answer 4

另一种方法是使用 list monad：

interleavings xs ys = interl xs ys ++ interl ys xs where
  interl [] ys = [ys]
  interl xs [] = [xs]
  interl xs ys = do
    i <- [1..(length xs)]
    let (h, t)  = splitAt i xs
    map (h ++) (interl ys t)

因此，递归部分将在两个列表之间交替，依次从每个列表中取出 1 到 N 个元素，然后生成所有可能的组合。 list monad 的有趣使用。

编辑：修复了导致重复的错误

编辑：回答 dfeuer。在注释字段中编写代码变得很棘手。不使用length 的解决方案示例可能类似于：

interleavings xs ys = interl xs ys ++ interl ys xs where 
  interl [] ys = [ys]
  interl xs [] = [xs]
  interl xs ys = splits xs >>= \(h, t) -> map (h ++) (interl ys t)

splits [] = []
splits (x:xs) = ([x], xs) : map ((h, t) -> (x:h, t)) (splits xs)

拆分功能感觉有点尴尬。可以将takeWhile 或break 与splitAt 结合使用来替换它，但该解决方案最终也有点尴尬。你有什么建议吗？

（我去掉了 do 符号只是为了让它稍微短一些）

Answer 5

结合现有答案中的最佳想法并添加一些我自己的想法：

import Control.Monad

interleave [] ys = return ys
interleave xs [] = return xs
interleave (x : xs) (y : ys) =
  fmap (x :) (interleave xs (y : ys)) `mplus` fmap (y :) (interleave (x : xs) ys)

interleavings :: MonadPlus m => [[a]] -> m [a]
interleavings = foldM interleave []

这不是你能得到的最快的，但在通用和简单方面应该不错。