Combinatorics: St. Peter's Game algorithm

Question

There's a combinatorics puzzle (as mentioned in Mathematics From the Birth of Numbers by Jan Gullberg) where if you line up fifteen members from two categories each (e.g. fifteen of category 0 and fifteen of category 1 for a total of 30 elements) mixed up in a certain order, then if you continuously go along this line in a circular fashion (i.e. wrapping around back to the start when you reach the end, continuing counting as you go) throwing out every ninth element, you'll eventually have just the elements of the one "favored" (1) category

line = [1,1,1,1,0,0,0,0,0,1,1,0,1,1,1,...]

line (see the run-length encoded tuples version below) is the actual ordering, that if you throw out every ninth,

line = [1,1,1,1,0,0,0,0,1,1,0,1,1,1,...] -- 9th thrown out

you'll always be throwing out the "disfavored" 0. If seen from the RLE tuples standpoint (where (0|1, n) encodes n consecutive occurrences of the 0 or the 1), (decrementing) from the tuple (0,x), i.e., decrementing the x, you'll eventually get down to just the (1,y) tuples, of course throwing out the fully depleted (0,0) tuples as well and recompacting the list as you go

line = [(1,4),(0,5),(1,2),(0,1),(1,3),(0,1),(1,1),(0,2),(1,2),(0,3),(1,1),(0,2),(1,2),(0,1)]

I've got this to get started

tally = foldl (\acc elem -> if (snd(elem)+acc) >= 9
                            then (snd(elem)+acc)-9
                            else (snd(elem)+acc)) 0

and when I feed it line

tally [(1,4),(0,5),(1,2),(0,1),(1,3),(0,1),(1,1),(0,2),(1,2),(0,3),(1,1),(0,2),(1,2),(0,1)]

it takes the 4 of the first tuple, then adds the 5 of the second, gets 9 and resets the accumulator to start the "counting down the line" again. And so it accurately returns 3 which is, in fact, the leftover of the accumulator after going along for one pass and identifying the tuple with the ninth and resetting the accumulator. My obvious problem is how to go beyond just identifying the ninth elements, and actually start decrementing the 0 tuples' elements, as well as throwing them out when they're down to (0,0) and re-running. I'm sure it would be easier to just build line as

line = [1,1,1,1,0,0,0,0,0,1,1,0,1,1,1,...]

and start chucking (i.. removing) the ninth, again, which should always be a 0 element, (e.g., the first ninth has been eliminated from line

line = [1,1,1,1,0,0,0,0,1,1,0,1,1,1,...]

but this is more of a challenge because I essentially need a fold to be combined with a map -- which is what I want to learn, i.e., a purely functional, no counters, etc., style. Hints and help appreciated. Also, if someone in the combinatorics lore could shed some theory light on what's happening here, that would be nice, too.

Answer 1

Looking for maps and folds might be overconstraining things, because here's a cute no-frills function for you to start with:

-- Remove the n-th element (zero-indexed) of a run-length encoded sequence of a.
chuck :: Int -> [(a, Int)] -> [(a, Int)]

Throw out the empty case; we're not supposed to be here.

chuck _ [] = error "unexpected empty list"

Let's compute chuck n ((a,m) : l). We're facing m identical elements a, and we want to delete the n-th element. That depends on whether n < m (i.e., whether the search stops in the middle of those m elements, or after).

If n < m, then we will remove one of those a. We can also prepare the result in anticipation for the next cycle, which resumes right after that a we removed. We've actually skipped n other elements before it, and a good place to store these n elements is the end of the list, since we're supposed to circle back around at the end anyway. We would need something more sophisticated if we wanted to count laps, but unless told otherwise, YAGNI. There remain m-n-1 elements, left at the front. A little helper rpt helps in the case where we are trying to append zero elements.

otherwise, we skip all m elements, store them in the back, and we have n-m more to go.

chuck n ((a,m) : l)
  | n < m = rpt a (m-n-1) ++ l ++ rpt a n
  | otherwise = chuck (n-m) (l ++ [(a,m)])
  where rpt a 0 = []
        rpt a n = [(a,n)]

(Note: this splits up (a,m) into (a,m-n-1) and (a,n), but doesn't merge them back... Left as an exercise for the reader.)

Since the result is prepared for the next iteration, we can easily chain chuck to see the evolution of the line. Note that elements are zero-indexed in this implementation, so chuck 8 chucks the "ninth" element.

ghci
> line
[(1,4),(0,5),(1,2),(0,1),(1,3),(0,1),(1,1),(0,2),(1,2),(0,3),(1,1),(0,2),(1,2),(0,1)]
> chuck 8 line
[(1,2),(0,1),(1,3),(0,1),(1,1),(0,2),(1,2),(0,3),(1,1),(0,2),(1,2),(0,1),(1,4),(0,4)]
> chuck 8 $ chuck 8 line
[(0,1),(1,2),(0,3),(1,1),(0,2),(1,2),(0,1),(1,4),(0,4),(1,2),(0,1),(1,3),(0,1),(1,1)]

This is a bit hard to follow. At the very least, we should make sure that only 0's are being chucked. So let's count the elements:

tally :: [(Int,Int)] -> (Int, Int)
tally xs = (sum (map snd (filter ((== 0) . fst) xs)), sum (map snd (filter ((== 1) . fst) xs)))

The right side of the tally seems to remain constant, and there is less on the wrong side, as expected:

> tally line
(15,15)
> tally $ chuck 8 line
(14,15)
> tally $ chuck 8 $ chuck 8 line
(13,15)

We can go faster with iterate, which repeatedly applies a function and returns all intermediate results in an infinite list:

> :t iterate
iterate :: (a -> a) -> a -> [a]

Iterate chuck 8, tally up, only look until where we expect to stop (after removing all 15 elements on one side):

> take 16 $ map tally $ iterate (chuck 8) line
[(15,15),(14,15),(13,15),(12,15),(11,15),(10,15),(9,15),(8,15),(7,15),(6,15),(5,15),(4,15),(3,15),(2,15),(1,15),(0,15)]

Answer 2

Using RLE complicates things. All you need is counting:

line = [(1,4),(0,5),(1,2),(0,1),(1,3),(0,1),(1,1),
        (0,2),(1,2),(0,3),(1,1),(0,2),(1,2),(0,1)]
unRLE rle = [c | (c,n) <- rle, c <- replicate n c]
test = count9 1 (sum [n | (0,n) <- line]) -- 15 
                [] $ unRLE line

count9 _ 0 rev line   = reverse rev ++ line
count9 9 n rev (0:xs) = count9 1 (n-1) rev xs
 -- removing 1 is error:
count9 9 n rev (1:xs) = error "attempt to remove 1"
count9 i n rev (x:xs) = count9 (i+1) n (x:rev) xs
count9 i n rev []     = count9 i n [] (reverse rev)

Running it

> test
[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]

You will need to tweak this if you want to see the state of the line on each 0 being removed.