在Haskell中缩短Knuth的算法M（混合基数）

Question

这是我实现Knuth算法M的C ++代码，它生成混合基数：

#include "visit.h"

void algorithmM(vector<int>& m)
{
  m.insert(m.begin(),2);
  const int n=m.size();
  vector<int> a(n,0);
  M2:
  visit(false,a);
  int j=n-1;
  M4:
  if (a[j]==m[j]-1) {a[j]=0;--j;goto M4;}
  if (j==0) return;
  else {a[j]++;goto M2;}
  }
int main()
{
  vector<int> m;
  int i;
  while(std::cin>>i)
  {if(i<0) continue;
   m.push_back(i);
  }
algorithmM(m);
return 0;
}

这是“visit.h”的代码：

#include <iostream>
#include <vector>

using std::vector;
using std::cout;

template<class T> void visit(bool first,vector<T>& l)
{
 size_t dt=first?0:1;
 for(typename vector<T>::iterator i=l.begin()+dt;i!=l.end();++i)
cout<<*i;
 cout<<'\n';
}

C ++代码非常接近Knuth的伪代码。 现在，这是使用可变数组的命令式Haskell实现：

import Data.Array.IO
import Control.Monad.State
import Data.IORef

data CountList = CountList {intlist::[Int],count::Int}
lenarr arr = do
         b<-getBounds arr
         return (snd b)

takeInput :: State (String,Int) [Int]
takeInput = do
        (s,count)<-get
        let g=reads s
        if g==[] then return []
        else do
            put (snd(head g),count+1)
            l<-takeInput
            return $ (fst(head g)):l
takeInput2 :: String->CountList
takeInput2 s = let (l,ss)=runState (takeInput) (s,0)
        in CountList l (snd ss)

fillArray :: CountList->IO((IOArray Int Int),(IOArray Int Int))
fillArray l = do
        arr<-newArray (0,(count l)) 0
        x<-nowfill 1 (intlist l) arr
        y<-newArray (0,(count l)) 0
        writeArray x 0 2
        return (x,y)

 where nowfill i l arr = do
             if l==[] then return arr
             else do
                writeArray arr i (head l)
                nowfill (i+1) (tail l) arr
visit ::(IOArray Int Int)->Int->IO ()
visit x i = do
          c<-lenarr x
          if i>c then putStrLn ""
          else do
                a<-readArray x i
                putStr (show a)
                visit x (i+1)

maj :: (IOArray Int Int)->(IOArray Int Int)->Int->IO((IOArray Int Int),Int)
maj m a j = do
        valaj <- readArray a j
        valmj <- readArray m j
        if valaj==valmj-1 then
                  do
                      writeArray a j 0
                      maj m a (j-1)
        else
            return (a,j)
m5 :: (IOArray Int Int)->Int->IO((IOArray Int Int),Int)
m5 a j = if j==0 then
         return (a,j)
     else do
         valaj<-readArray a j
         writeArray a j (valaj+1)
         return (a,j)
algorithmM0 m a = do
    visit a 1
    n<-lenarr m
    (a',j)<-maj m a n
    (a'',j')<-m5 a' j
    if j'==0 then
          return ()
    else
        algorithmM0 m a''
algorithmM = do
    l<-getLine
    let mycountlist = takeInput2 l
    (m,a)<-fillArray mycountlist
    algorithmM0 m a
main :: IO ()
main = algorithmM

我也有一个更实用的方法，使用Haskell中的列表，虽然较小，但我不想放大帖子。

你能否就如何缩小Haskell代码给我一些建议？

我认为使用像Haskell这样的高级语言的主要原因是编写更少的代码，但我认为这不会发生，所以我认为我做错了。

Answer 1

功能方法非常简洁：

algom = sequence . map (\n -> [0..n-1])

algom [2,3,4]
  -- [[1,1,1],[1,1,2],[1,1,3],[1,1,4],[1,2,1],[1,2,2],[1,2,3],[1,2,4],[1,3,1],[1,3,2],[1,3,3],[1,3,4],[2,1,1],[2,1,2],[2,1,3],[2,1,4],[2,2,1],[2,2,2],[2,2,3],[2,2,4],[2,3,1],[2,3,2],[2,3,3],[2,3,4]]

即使你实现了算法M的较短版本，它仍然会在IO monad中，因此任何使用它的代码也必须在IO monad中（如果使用ST数组，则必须在ST monad中）。

除非有迫切的理由使用可变阵列，否则我会坚持使用功能版本。

在任何情况下，这里是算法M的可变数组版本：

import Data.Array.MArray (getBounds,writeArray,readArray,newArray,getElems)
import Data.Array.IO
import Control.Monad.Loops (untilM_)


next :: IOArray Int Int -> IOArray Int Int -> IO Bool
next rarr arr =                              -- radix array, digit array
  do (first,last) <- getBounds arr
     let go k | k < first = return True      -- end reached
         go k = do d <- readArray arr k
                   r <- readArray rarr k
                   let newd = d+1
                   if newd >= r
                     then do writeArray arr k 0
                             go (k-1)
                     else do writeArray arr k newd
                             return False    -- more to come
     go last

showArray :: IOArray Int Int -> IO ()
showArray arr = do
  nums <- getElems arr
  putStrLn $ show nums


(-->) = flip fmap

main = do nums <- getContents --> words --> map read --> takeWhile (>= 0)
          let n = length nums
          rarr <- newListArray (1,n) nums
          arr <- newArray (1,n)  0
          untilM_ (showArray arr) (next rarr arr)

Answer 2

算法M的纯粹部分确实很短：

algorithmM = mapM (\n -> [0..n-1])

例如，这是ghci中的一个运行：

> algorithmM [2,3]
[[0,0],[0,1],[0,2],[1,0],[1,1],[1,2]]

在它周围放置一个输入/输出循环也很容易。 例如，我们可以添加

main = readLn >>= mapM_ print . algorithmM

编译并运行包含这两行（！）的程序，您将看到如下内容：

% ./test
[2,3]
[0,0]
[0,1]
[0,2]
[1,0]
[1,1]
[1,2]