Knuth's algorithm M that produces mixed-radix numbers

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

#include "visit.h"

void algorithmM(vector& m)
{
  m.insert(m.begin(),2);
  const int n=m.size();
  vector 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 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 
#include 

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

template void visit(bool first,vector& l)
{
 size_t dt=first?0:1;
 for(typename vector::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
         bCountList
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
        arrInt->IO ()
visit x i = do
          cc then putStrLn ""
          else do
                a(IOArray Int Int)->Int->IO((IOArray Int Int),Int)
maj m a j = do
        valaj 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

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  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 > 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 >= 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

StackExchange Code Review Q#42509, answer score: 2