A Puzzle and a Solution (2)

by Mithrandir

Last post was ended with a problem: our solution exhausted the memory before it could give an answer to N=1000, P=42. There were three comments trying to solve them and the last two of them are working. However, the solution involving the lcm of cycles is faster and I will post it here (the other one is posted as a comment there).

My solution uses arrays for constant time access, though a good running time can be obtained if using the standard lists functions.

import Data.Array

To obtain the array is simple, as shown by the following code:

constructPairs :: [Int] -> [(Int, Int)]
constructPairs perm = zip [0..l] perm
  where
    l = length perm
 
toArray :: [(Int, Int)] -> Array Int Int
toArray pair = array (0, l) pair
  where
    l = length pair - 1

Now, we can obtain the solution

getCycle :: Array Int Int -> Int -> [Int]
getCycle a x = (x:) $ takeWhile (\e -> e /= x) $ iterate (a!) $ (a!) x
 
getCycleLengths :: [Int] -> [Int]
getCycleLengths perm = map (\i -> length $ getCycle a i) perm
  where
    a = toArray $ constructPairs perm
 
computeOrder' :: [Int] -> Int
computeOrder' perm = foldl lcm 1 $ getCycleLengths perm
 
solution :: Int -> Int -> Int
solution n p = computeOrder' $ getAllKicks n p

This way, both solutions are obtained in less than a second (and the answer to N=1000,P=42 is 836,744,980)

About these ads