### A Puzzle and a Solution

#### by Mithrandir

Let’s say we have a number of children placed in a circle and playing the following simple game: proceeding around the circle they kick out every th of them (of course, ).

Of course, what we will obtain is a permutation of the first natural numbers. The puzzle asks for the order of this permutation (that is the number of times it must be applied to itself to get back to an ordered list.

For Computer Science’s sake (in fact, because indexing starts at 0), we will label each element starting from 0 and not from one. This will not change the answer to the puzzle and will not make things simpler.

For example, suppose we have and . Then, the permutation we obtain is which has the order 3.

We will solve this puzzle using Haskell. First, we will define a new data type to represent the circle of children:

`data Ring a = Ring [a] a [a] deriving Show`

The circle is represented as two lists of children and one active one. The first list represents his left neighbours while the last list contains his right neighbours. Thus, to construct one instance of the problem and to switch our focus (the count) from one child to the other we have those functions:

`circle :: Int -> Ring Int`

circle n = Ring [] 0 [1..(n-1)]

next :: Ring a -> Ring a

next (Ring l n []) = Ring [] h hs

where

(h:hs) = reverse (n:l)

next (Ring l n (f:fs)) = Ring (n:l) f fs

circle n = Ring [] 0 [1..(n-1)]

next :: Ring a -> Ring a

next (Ring l n []) = Ring [] h hs

where

(h:hs) = reverse (n:l)

next (Ring l n (f:fs)) = Ring (n:l) f fs

Now, we will turn our attention to the removal of a child from the circle. At first, we would be tempted to write a function with the following signature:

`remove :: Ring a -> Ring a`

But this will not work after we have eliminated the last child. Of course, we can always check if there are more children before proceeding to eliminate one but this will lead to code cluttered with if/else clauses and I don’t like this. It is better to take advantage of Haskell laziness as will be obvious in the end of this post.

Thus, we will make use of the Maybe datatype

`remove :: Ring a -> Maybe (Ring a)`

remove (Ring [] n []) = Nothing

remove (Ring l n []) = Just $ Ring [] h hs

where

(h:hs) = reverse l

remove (Ring l n (f:fs)) = Just $ Ring l f fs

remove (Ring [] n []) = Nothing

remove (Ring l n []) = Just $ Ring [] h hs

where

(h:hs) = reverse l

remove (Ring l n (f:fs)) = Just $ Ring l f fs

Now, we can obtain the permutation using two simple functions:

`getOneKick :: Ring Int -> Int -> (Int, Maybe (Ring Int))`

getOneKick r@(Ring _ x _) 1 = (x, remove r)

getOneKick r n = getOneKick (next r) (n -1)

getAllKicks :: Int -> Int -> [Int]

getAllKicks n p = fst $ until (\p -> snd p == Nothing) kick init

where

init = ([], Just $ circle n)

kick (l, Just r) = (((fst a) : l), snd a)

where

a = getOneKick r p

getOneKick r@(Ring _ x _) 1 = (x, remove r)

getOneKick r n = getOneKick (next r) (n -1)

getAllKicks :: Int -> Int -> [Int]

getAllKicks n p = fst $ until (\p -> snd p == Nothing) kick init

where

init = ([], Just $ circle n)

kick (l, Just r) = (((fst a) : l), snd a)

where

a = getOneKick r p

Now, we have the permutation. We need only to compute it’s order and we’re done.

`applyPerm :: [Int] -> [Int] -> [Int]`

applyPerm l p = map (\i -> l !! i) p

computeOrder :: [Int] -> Int

computeOrder perm = fst $ until test f $ f init

where

l = length perm - 1

test p = snd p == [0 .. l]

f (a, list) = (a+1, applyPerm list perm)

init = (0, [0 .. l])

applyPerm l p = map (\i -> l !! i) p

computeOrder :: [Int] -> Int

computeOrder perm = fst $ until test f $ f init

where

l = length perm - 1

test p = snd p == [0 .. l]

f (a, list) = (a+1, applyPerm list perm)

init = (0, [0 .. l])

After this, the puzzle’s solution is simple:

`solution :: Int -> Int -> Int`

solution n p = computeOrder $ getAllKicks n p

solution n p = computeOrder $ getAllKicks n p

We obtain the answer (2350) for and in a few seconds but it takes too much time to solve for and . Eventually, it runs out of memory :(

Maybe trying to evaluate some of the lists (or the Ring) strictly would solve this particular problem? Maybe even make the program run a bit faster.

No, the problem is not in the generation of the permutation. I have obtained it in at most 1 second.

The problem lies in the code which computes the order of the permutation

Factor the permutation into cycles, and take the lcm of the cycle lengths.

At a (post-NYE, pre-coffee!) guess it’s the all +1s eating your memory. At another guess this might behave better:

Apologies for whatever the comment-formatting did to that!

Yes, this will be faster. I’ll do an update in a few hours/days.

@Greg: this works too but Aaron’s solution is faster. Thanks

Ha! I assumed you chose to do it the slow way specifically to demonstrate laziness.

I wanted to use until :P

I wanted to suggest Aaron’s solution, but he was faster. Using the combinat library http://hackage.haskell.org/package/combinat (in which indexing starts from 1, because it’s mathematics, not computer science :)

foldl1 lcm $ map length $ fromDisjointCycles $ permutationToDisjointCycles $ toPermutation $ map (+1) $ getAllKicks 1000 42

gives 1173360916 in 1 sec. (disclaimer: post-NYE, too)

I simply wanted to add a comment here to say thanks for you very nice ideas. Blogs are troublesome to run and time consuming therefore I appreciate when I see well written material. Your time isn’t going to waste with your posts. Thanks so much and carry on You’ll defintely reach your goals! have a great day!