This is the C++ code of my implementation of Knuth's algorithm M that produces mixed-radix numbers:#include visit.hvoid 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.IOimport Control.Monad.Stateimport Data.IORefdata 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)):ltakeInput2 :: String->CountListtakeInput2 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) arrvisit ::(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 amain :: IO ()main = algorithmMI 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.
Knuth's algorithm M that produces mixed-radix numbers
optimization;algorithm;haskell
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.IOtype AlgoArray = IOArray Int Int -- allows for experimentation with IOUArray or otherslenarr :: AlgoArray -> IO Int  -- simplified typelenarr arr = getBounds arr >>= return . sndfillArray :: [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 nsvisit :: 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) cmaj :: 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 . wordsmain :: IO ()main = algorithmM