A Puzzle and a Solution

by Mithrandir

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

Of course, what we will obtain is a permutation of the first N 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 N = 4 and P = 2. Then, the permutation we obtain is \left(\begin{array}{cccc}0&1&2&3\\ 0&2&3&1\end{array}\right) 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

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

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

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])

After this, the puzzle’s solution is simple:

solution :: Int -> Int -> Int
solution n p = computeOrder $ getAllKicks n p

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

About these ads