Are recursive calls in my "permutations with repetition" code accumulated to clog the RAM?

Question

A bit of background:

I am an amateur programmer, having picked up Haskell a few months ago, on my spare time, after a period of Mathematica programmning (my first language). I am currently going through my second Haskell book, by Will Kurt, but I still have miles to go to call myself comfortable around Haskell code. Codeabbey has been my platform for experimentation and learning so far.

I have written a piece of code to generate permutations of a given number, that deals with possible duplicate numbers, so for 588 it will internally generate 588, 858 and 885.

However, because I want to scale to pretty big input numbers (think perhaps even a hundred digits long), I don't want to output the whole list and then perform calculations on it, instead every number that is generated is checked on the spot for a certain property and if it has it, well, we have a winner, the number is returned as output and there's no need to go through the rest of the humongous list. If sadly no desired number is found and we unsuccessfully go through all possible permutations, it outputs a "0".

I have also opted to make it a command line program to feed values to it via gnu parallel for faster work.

So here is the code

import System.Environment

import Data.List 

toDigits :: Integer -> [Integer]
toDigits n = map (\n -> read [n]) (show n)

fromDigits :: Integral a => [a] -> Integer
fromDigits list = fromDigitsHelperFunction list 0

fromDigitsHelperFunction :: Integral a => [a] -> Integer -> Integer
fromDigitsHelperFunction [] acc = acc
fromDigitsHelperFunction (x:[]) acc = (fromIntegral x) + acc
fromDigitsHelperFunction digits@(x:xs) acc = fromDigitsHelperFunction xs (acc + ((fromIntegral x) * 10 ^((length digits) - 1 )))

testPermutationsWithRepetition :: ([Integer],Int,[Int],[(Int,Integer)]) -> [Integer]
testPermutationsWithRepetition (digits, index, rotationMap, registeredPositions)
   | index == 0 && rotationMap !! index == 0                                    = [0,0,0] --finish state (no more recursion). Nothing more to do
   | index == digitsLength - 1 && beautyCheck (fromDigits digits)           = digits
   | index == digitsLength - 1                                                  = testPermutationsWithRepetition (digits, index-1, rotationMap, registeredPositions)
   | not ((index,digits!!index) `elem` registeredPositions)                     = testPermutationsWithRepetition (digits, index+1, rotationMap, (index,digits!!index):registeredPositions)
   | rotationMap!!index == 0                                                    = testPermutationsWithRepetition (digits, index-1, restoredRotMap, restoredRegPositions)
   | rotationMap!!index > 0 && (index,digits!!index) `elem` registeredPositions = testPermutationsWithRepetition (shiftLDigits, index, subtractRot, registeredPositions)
   where digitsLength = length digits
         shiftLDigits = (fst splitDigits) ++ (tail $ snd splitDigits) ++ [head $ snd splitDigits]
         splitDigits = splitAt index digits
         restoredRotMap = (fst splitRotMap) ++ [digitsLength - index] ++ (tail $ snd splitRotMap)
         splitRotMap = splitAt index rotationMap
         restoredRegPositions = filter (\pos -> fst pos < index) registeredPositions  --clear everything below the parent index
         subtractRot = (fst splitRotMap) ++ [(head $ snd splitRotMap) - 1] ++ (tail $ snd splitRotMap)


--Frontend function for testing permutations by inputting a single parameter (the number in digit form)
testPermsWithRep :: [Integer] -> [Integer]
testPermsWithRep digits = testPermutationsWithRepetition (digits, 0, [length $ digits, (length $ digits) -1 .. 1], [])

main :: IO ()
main = do
   args <- getArgs
   let number = read (head args) :: Integer
   let checkResult = fromDigits $ testPermsWithRep $ toDigits number
   print checkResult

It's really a sequential process with an index variable that points to a certain number on the digit list and performs a recursive call on that list based on my rules. The functions tracks its progress through the digit list for visited numbers in certain positions so far (to avoid repetition following already visited paths until it gets to the last digit (index == length -1). If the number that we get there passes the beauty check, it exits with the number produced.

Now, in a Mathematica (or I guess any imperative language) I would probably implement this with a While loop and Cases for its checks, and by the logic of the program, however long it took to compute (generate the permutations and check them for validity) it would take a moderate amount of memory, just enough to hold the list of "registeredPositions" really (you could call it the record of visited digits in specific positions, so it's a variable list as we go deeper in index but gets cleaned up as we move back up). However in this case, the recursive calls stack up as it seems and the whole thing acts as a fork bomb for sufficiently large numbers (e.g 27777772222222222222222223333) and eventually crashes. Is this behaviour something that can be handled differently in Haskell or is there no way to avoid the recursion and memory hogging?

I really like Haskell because the programs make logical sense, but I would like to use it also for cases like this where performance (and resources) matters.

As a side note, my brother pointed to this Algorithm to print all permutations with repetition of numbers in C that is reasonably fast (only generates a list though) and most importantly has minimal memory footprint, although I can tell there's also recursion used in it. Other that that I'm clueless when it comes to C and I would like to stick to Haskell, if it can do what I want at the end of the day, that is.

Any help is welcome. Have a good day!

Edit: Per Soleil's suggestion I update my post with additional info provided in the comments. Specifically:

1. After compiling with "ghc checking_program.hs" I run the program with "./checking program 27777772222222222222222223333". On an i5 3470 with 4GB RAM it runs for about 10 minutes and exits with a segmentation fault. On my brothers 32GB machine he let it run until it took up 20GB of RAM. No need to go further I guess. My tests were on Ubuntu via Win10 WSL. His is bare Linux

2. testPermsWithRep is just a front end for testPermutationsWithRepetition, so that I can only provide the number and testPermsWithRep creates the initial parameters and calls testPermutationsWithRepetition with those. It outputs exactly what testPermutationsWithRepetition outputs, either a number (in digit form) that passes the test, or [0,0,0]. Now the test, the beautyCheck function is simply a test for single digit divisors of that number, that returns True or False. I didn't include it because it really is inconsequential. It could even be just a "bigger than x number" test.

An an example, calling "testPermsWithRep [2,6,7,3]" will call "testPermutationsWithRepetition ([2,6,7,3], 0, [4,3,2,1],[])" and whatever comes out of that function, testPermsWithRep will return that as well.

Answer 1

The performance issue with your program doesn't have anything to do with recursion. Rather, you seem to be running up against an accumulation of a partially evaluated, lazy data structure in your rotation map. Your program will run in constant memory if you use the deepseq package to fully force evaluation of the restoredRotMap:

-- Install the `deepseq` package and add this import
import Control.DeepSeq

-- And then change this one case
... | rotationMap!!index == 0 = restoredRotMap `deepseq`
      testPermutationsWithRepetition (digits, index-1, restoredRotMap, restoredRegPositions)

Compiled with ghc -O2 and using beautyMap _ = False, this runs with a fixed resident memory usage of about 6 megs.

Some other performance targets:

• You might want to replace most of your Integer types with Int, as this will be faster. I think you only need Integer for the input to toDigits and the output of fromDigits, and everything else can be Int, since it's all indexes and digits.
• An even bigger win will be to replace your rotation map and registered positions with better data structures. If you find yourself splicing up lists with lots of listpart1 ++ [x] ++ listpart2 calls, there are going to be enormous performance costs to that, and the linear lookups with (!!) aren't helping either.

Answer 2

So I am not 100% sure of this and I am also not 100% sure I understand your code. But as far as I understand you are generating permutations without duplicates and then you are checking for some predicate wanting whatever single number that fulfils it.

I think it should help to use as many of the prelude functions as possible because afaik then the compiler understands it can optimize recursion into a loop. As a rule of thumb I was taught to avoid explicit recursion as much as possible and instead use prelude functions like map, filter and fold. Mainly you avoid reinventing the wheel this way but there also should be a higher chance of the compiler optimizing things.

So to solve your problem try generating a list of all permutations, then filter it using filter and then just do take 1 if you want the result that is found first. Because of Haskell's lazy evaluation take 1 makes it so that we are interested only in the first x in (x:xs) that a filter would return. Therefore filter will keep dropping elements from the, again lazily evaluated, list of permutations and when it finds one it stops.

I found a permutation implementation on https://rosettacode.org/wiki/Permutations#Haskell and used it to try this call:

take 1 $ filter ((> 67890123456789012345) . fromDigits) $ permutations' $ toDigits 12345678901234567890

it has been running for like 20 minutes now and RAM usage has stayed around 230 MB.
I hope that has answered/helped you at least in some way.

+ a bonus tip: you can simplify your fromDigits to this beautiful thing:

fromDigits :: Integral a => [a] -> Integer
fromDigits = foldl shiftAndAdd 0
    where shiftAndAdd acc d = 10 * acc + fromIntegral d

EDIT:
I read some more of the comments and I see you care about ignoring duplicates but I am afraid you'll have to go smarter about that, since if I understand correctly your implementation still generates all the duplicates it only throws them away after checking if they are in a list (which has O(n) complexity). And when you only care about finding one permutation that fits your predicate you drop the not fitting ones anyway.

And people have already correctly pointed out that !! is generally also very bad.

Answer 3

Thanks to everyone for your helpful answers and comments.

@lordQuick permuations used with filter is still terrible but that fromDigits code is a beauty, so I used it.

@k-a-buhr That's exactly what I did yesterday, also per others suggestion, I replaced all use of !! and ++. When I did the latter all memory problems disappeared. Wow! I mean I knew ++ is bad I just didn't realise how bad! We're talking orders of magnitude bad! 3M of RAM vs several GB. Also, valid point about integers. I will try that.

Oh, also a very important thing. I replaced recursive calls with until. This is the approach I would have followed in Mathematica (a NestWhile function to be exact), and I'm glad I found it in Haskell. It seemed to make things a bit faster too.

Anyway, the revised code, that solves my memory issues is here for anyone if interested.

{-compiled with "ghc -Rghc-timing -O2 checking_program_v3.hs"-}

import System.Environment
import Data.List


--A little help with triples
fstOfThree (a, _, _) = a
sndOfThree (_, b, _) = b
thrOfThree (_, _, c) = c

--And then some with quads
fstOfFour (a, _, _, _) = a
sndOfFour (_, b, _, _) = b
thrOfFour (_, _, c, _) = c

--This function is a single pass test for single digit factors
--It will be called as many times as needed by pryForSDFactors
trySingleDigitsFactors :: (Bool, Integer, [Integer]) -> (Bool, Integer, [Integer])
trySingleDigitsFactors (True, n, f) = (True, n, f)
trySingleDigitsFactors (b, n, []) = (b, n, [])
trySingleDigitsFactors (b, n, (f:fs))
   | mod n f == 0 = (True, div n f, fs)
   | otherwise = trySingleDigitsFactors (False, n, fs)

--This function will take a number and repeatedly divide by single digits till it gets to a single digit if possible
--Then it will return True
pryForSDFactors :: Integer -> Bool
pryForSDFactors n
   | sndOfThree sdfTry < 10 = True
   | fstOfThree sdfTry == True = pryForSDFactors $ sndOfThree sdfTry
   | otherwise = False
   where sdfTry = trySingleDigitsFactors (False, n, [7,5,3,2])

toDigits :: Integer -> [Integer]
toDigits n = map (\n -> read [n]) (show n)

fromDigits :: Integral a => [a] -> Integer
fromDigits = foldl shiftAndAdd 0
    where shiftAndAdd acc d = 10 * acc + fromIntegral d

replaceElementAtPos :: a -> Int -> [a] -> [a]
replaceElementAtPos newElement pos [] = []
replaceElementAtPos newElement 0 (x:xs) = newElement:xs
replaceElementAtPos newElement pos (x:xs) = x : replaceElementAtPos newElement (pos-1) xs

checkPermutationsStep :: ([Integer],Int,[Int],[(Int,Integer)]) -> ([Integer],Int,[Int],[(Int,Integer)])
checkPermutationsStep (digits, index, rotationMap, registeredPositions)
   | index == digitsLength - 1                                               = (digits, index-1, rotationMap, registeredPositions)
   | not ((index, digitAtIndex) `elem` registeredPositions)                  = (digits, index+1, rotationMap, (index,digitAtIndex):registeredPositions)
   | rotationAtIndex == 0                                                    = (digits, index-1, restoredRotMap, restoredRegPositions)
   | rotationAtIndex > 0 && (index, digitAtIndex) `elem` registeredPositions = (shiftLDigits, index, subtractRot, registeredPositions)
   where digitsLength = length digits
         digitAtIndex = head $ drop index digits
         rotationAtIndex = head $ drop index rotationMap
         --restoredRotMap = (fst splitRotMap) ++ [digitsLength - index] ++ (tail $ snd splitRotMap)
         restoredRotMap = replaceElementAtPos (digitsLength - index) index rotationMap
         --splitRotMap = splitAt index rotationMap
         restoredRegPositions = filter (\pos -> fst pos < index) registeredPositions  --clear everything below the parent index
         shiftLDigits = (fst splitDigits) ++ (tail $ snd splitDigits) ++ [head $ snd splitDigits]
         splitDigits = splitAt index digits
         --subtractRot = (fst splitRotMap) ++ [(head $ snd splitRotMap) - 1] ++ (tail $ snd splitRotMap)
         subtractRot = replaceElementAtPos (rotationDigitAtIndex - 1) index rotationMap
         rotationDigitAtIndex = head $ drop index rotationMap

checkConditions :: ([Integer],Int,[Int],[(Int,Integer)]) -> Bool
checkConditions (digits, index, rotationMap, registeredPositions)
   | (index == 0 && rotationAtIndex == 0) || ((index == (length digits) - 1) && pryForSDFactors (fromDigits digits)) = True
   | otherwise = False
   where rotationAtIndex = head $ drop index rotationMap

testPermsWithRep :: Integer -> Integer
testPermsWithRep n
   | sndOfFour computationResult == 0 && (head . thrOfFour) computationResult == 0 = 0
   | otherwise = (fromDigits . fstOfFour) computationResult
   where computationResult = until checkConditions checkPermutationsStep (digitsOfn, 0 , [digitsLength, digitsLength -1 .. 1], [])
         digitsOfn = toDigits n
         digitsLength = length digitsOfn

main :: IO ()
main = do
   args <- getArgs
   let inputNumber = read (head args) :: Integer
   let checkResult = testPermsWithRep inputNumber
   print checkResult

Now, bear in mind that this code, as I've mentioned, checks for a condition of each generated permutation (single digit factors) on the spot, and moves on if False, but it's pretty easy to repurpose it for output list generation.

Sure it's now just inefficient in terms of big O complexity (scales terribly), and I was at first thinking of replacing lists with Data.Map because that's what I've learned so far (though not so comfortable with maps yet).

I've also read that there's a more efficient replacement for read since that's also called a lot for numbers-to-digits conversions.

@ lordQuick I don't know about HashMaps or vectors yet but I'm still learning. Every little optimization will pay off in computation time because this is my first piece of "practical" code, not just Codeabbey credit

Cheers!

Answer 4

Here is a solution using a more efficient, insertion-based algorithm to compute unique permutations:

import Data.List

permutationsNub :: Eq a => [a] -> [[a]]
permutationsNub = foldr (concatMap . insert) [[]]
    where insert y = foldr combine [[y]] . (zip <*> tail . tails)
              where combine (x, xs) xss = (y : x : xs) :
                        if y == x then [] else map (x :) xss

headDef :: a -> [a] -> a
headDef x [] = x
headDef x (h : t) = h

fromDigits :: Integral a => [a] -> Integer
fromDigits = foldl1' ((+) . (10 *)) . map fromIntegral

toDigits :: Integer -> [Int]
toDigits = map (read . pure) . show

firstValidPermutation :: (Integer -> Bool) -> Integer -> Integer
firstValidPermutation p =
    headDef 0 .
    filter p .
    map fromDigits .
    permutationsNub .
    toDigits

The basic idea is that, given the unique permutations of a list's tail, we can compute the unique permutations of the whole list by inserting its head into all of the tail's permutations, in every position that doesn't follow an occurrence of the head (to avoid creating duplicates). From my tests, permutationsNub seems to be faster than permutations from Data.List even when the input contains no repetitions. However, unlike that function, it consumes its input eagerly and thus cannot handle an infinite input. Exercise: Prove this algorithm's correctness.

to be continued