Newton Excel Bach, not (just) an Excel Blog

At Daily Dose of Excel Dick K. looks at a VBA solution to this problem:

Problem description: Take a stack of coins all heads up. Upturn the topmost coin, place back on the stack and then proceed: take the top 2 coins and upturn as a single stack (tail, head becomes when upturned and placed back on the stack tail, head (the two coins are flipped as if glued together)). Now in the same way flip the top 3 coins and place back on the stack (you get: tail, tail, head (and if there were 4 coins that would be tail, tail, tail, head). When you upturn the whole stack begin again with the first coin. Continue until you return to a stack with all heads up.

Dick’s macro produced this output for 1 to 50 coins:

Flips vs Number of Coins

I thought I’d see if I could come up with a reasonably tidy macro-free solution.  The formula I came up with is:

• =IF(D$1<$B2,C2,MOD(INDEX(C$2:C$100,C$1+$A2-$B2+2)+1,2))

This treats a zero as a head, and a 1 as a tail.  The formula was entered into cell D2 and copied into D2:I7 (for a 6 coin stack), with numbers 1 to 6 in D1:I1 zeros in A2:A7, 1 to 6 in B2:B7 and zeros in C2:C7 :

First 6 flips

Next cells D2:I7 were copied to D9:I14; =I2 was entered in C9 and copied down to C14; =A2+7 was entered in A9 and copied down to A14, and 1 to 6 entered in B9:B14

Second block of six flips

This block of 6×9 cells (A9:I14) can then be copied down as often as required:

Completed solution for 6 coins

Having done that, I thought I’d try a similar approach in VBA.  Here’s the code:

Sub CoinStack2()
Dim StackA() As Long, NumCoins As Long, Numtails As Long, NumIts As Long
Dim i As Long, j As Long, k As Long, L As Long, ItTable() As Long, NumOut As Long
Const MaxLoops As Long = 1000000

NumOut = 300
ReDim ItTable(1 To NumOut, 1 To 2)

For L = 1 To NumOut
NumCoins = L
ReDim StackA(1 To NumCoins, 1 To NumCoins + 1)
Numtails = 0
NumIts = 0
For i = 1 To MaxLoops
For j = 1 To NumCoins
StackA(j, 1) = StackA(j, NumCoins + 1)
            Next j

For j = 1 To NumCoins
NumIts = NumIts + 1
                For k = 1 To j
StackA(k, j + 1) = (StackA(j - k + 1, j) + 1) Mod 2
Numtails = Numtails - StackA(k, j) + StackA(k, j + 1)
                Next k
For k = j + 1 To NumCoins
StackA(k, j + 1) = StackA(k, j)
                Next k
If Numtails = 0 Then
ItTable(L, 1) = L
ItTable(L, 2) = NumIts
GoTo nextstack
                End If
            Next j
Next i
nextstack:
    Next L
Range("stacka").Resize(L - 1, 2) = ItTable
End Sub

Output for up to 300 coins is shown below:

Number of Iterations vs Number of Coins (click for full size view)

The trend seen in Dick’s graph is continued, in fact the number of flips required to return to all heads is never more than n^2 (where n is the number of coins), but the peaks are more often n^2-1, and the number of points between peaks doesn’t seem to have any clear trend.  Also the trend for the minimum number apparent in the 1-50 coin graph seems to have disappeared.

Correction: Following Mawdo’s comment I had another look at the minimums, and there is a pattern, and it is more regular than the maximums.  For the integers 1,2,3 … m:

• Coin stacks with (2^m)-1 coins are at a minimum
• The number of flips required is  ((2^m)-1)(m+1); i.e. number of coins x (m+1)
• The next stack (with 2^m coins) requires only (2^m)(m+1)-1 flips; i.e. number of coins x (m+1)-1
• There are no other stacks that require less than (number of coins) x (m+1) flips.

I have added these minimum points to the chart below:

Iterations vs Number of coins with minimum line