Knuth's algorithm M that produces mixed-radix numbers

Question

This is the C++ code of my implementation of Knuth's algorithm M that produces mixed-radix numbers:

#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;
}

This is the code of "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';
}

The C++ code is very close to the Knuth's pseudocode. And now this is an imperative Haskell implementation using mutable arrays:

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

I also have and a more functional approach using lists in Haskell which is smaller but I don't want to enlarge the post.

Can you please give me some advice on how to shrink the Haskell code?

I think that the main reason of using a high-level language like Haskell is to write less code but I don't think this happens here so I suppose that I am doing something wrong.

• Jamal: For the C++ code, I'd recommend indenting by four spaces as it's more readable. Two isn't enough, plus some of your curly braces are placed strangely.
• Dragno: Thanks for the comment, but for now my problem is the Haskell code.
• Jamal: I understand. That's mainly why I left that as a comment.

Answer 1

Below is a more idiomatic to Haskell version that still follows your original imperative logic. I know elsewhere on SO you have been shown how to do this efficiently and functionally. I did this to show what could be done if the design requirements remained in place.

This version is 52 lines long with all of the whitespace you see. The original was 84 lines after whitespace between the functions was added.

The entire takeInput design using State was not needed. As shown, map read . words is sufficient. If you are concerned about poor input then a version could quickly be put in place using reads but without State.

case replaces the if usage. This is more idiomatic in my experience and is still very readable. You get pattern matching along the way too.

Note that nowfill was replaced by newListArray and the entire CountList was discarded as unneeded. If it was valuable then fillArray could still use CountList without the need for nowfill. The entire function could be about two lines if Applicative style was used. But that would definitely veer pretty far from the straight forward imperative style.

visit was updated to move the putStrLn call outside of the recursion and uses a helper function instead of the old if/else style. Again, the same exact logic just using a more idiomatic layout.

The calls to uncurry could be removed if m5 and algorithmM0 took tuples instead of separated arguments. This does lend it a more functional flavor but I did not want to disturb the function types where possible.

There are no cute tricks in this code. It is pretty reasonable for even a beginner level Haskell developer to read and understand I think. A C coder unfamiliar with the language would have more difficulty following this version than the original I suspect.

import Data.Array.IO
type AlgoArray = IOArray Int Int -- allows for experimentation with IOUArray or others
lenarr :: AlgoArray -> IO Int -- simplified type
lenarr arr = getBounds arr >>= return . snd
fillArray :: [Int] -> IO (AlgoArray, AlgoArray)
fillArray ns = do -- could be Applicative style: (,) <$> newListArray <*> newArray
 x <- newListArray (0, lcount) (2:ns)
 y <- newArray (0, lcount) 0
 return (x, y)
 where
 lcount = length ns
visit :: AlgoArray -> Int -> IO ()
visit x i = lenarr x >>= visit' x i >> putStrLn ""
 where
 visit' x i c
 | i > c = return ()
 | otherwise = readArray x i >>= putStr . show >> visit' x (i + 1) c
maj :: AlgoArray -> AlgoArray -> Int -> IO (AlgoArray, Int)
maj m a j = do
 valaj <- readArray a j
 valmj <- readArray m j
 maj' valaj valmj
 where
 maj' valaj valmj
 | valaj == (valmj - 1) = writeArray a j 0 >> maj m a (j - 1)
 | otherwise = return (a, j)
m5 :: AlgoArray -> Int -> IO (AlgoArray, Int)
m5 a 0 = return (a, 0)
m5 a j = readArray a j >>= writeArray a j . (+1) >> return (a, j)
algorithmM0 :: AlgoArray -> AlgoArray -> IO ()
algorithmM0 m a = do
 visit a 1
 v <- lenarr m >>= maj m a >>= uncurry m5
 case v of
 (_, 0) -> return ()
 (a', _) -> algorithmM0 m a'
algorithmM :: IO ()
algorithmM = getLine >>= fillArray . takeInput >>= uncurry algorithmM0
 where
 takeInput = map read . words
main :: IO ()
main = algorithmM