Finding an Optimal Strategy for Shut The Box: Part 1

/

I’ve long been fascinated about how computers can be used to determine optimal - or even just good - strategies for playing games with well-defined rules, and in this blog I’ll be working through the creation of such a strategy for a game sometimes known as Shut The Box.

In the version on the game that I’ll be investigating, the rules are as follows:

  1. At the start, 9 “boxes” numbered 1 to 9 are “open”

  2. At each turn, two dice are rolled and we are allowed to shut boxes whose total exactly matches that of the two dice. So, for example, if all 9 boxes are still open and we roll a 7, we could choose to shut:

  • Box 7 only

  • Boxes 1 and 6, 2 and 5, or 3 and 4

  • Boxes 1, 2, and 4

3. We continue until either:

  • We roll a total that cannot be achieved with the remaining open boxes (eg we roll a total of 8 and only have boxes 1,2,3 an 9 still open). If that’s the case, we lose.

  • The remaining boxes total 3 or less (ie we have only box 1, 2, or 3 open, or we have only boxes 1 and 2 open). If that’s the case, we win

The question is then, given a set of open boxes and a rolled total, what is the best strategy?

DEFINING THE GAME SPACE

The first thing we need to do in or simulation is to create a dataframe that contains:

  1. All of the combinations of open boxes that we might face at the start if a roll

  2. All of the possible box combinations that we could shut give a roll and given the boxes still open

We achieve 1. with the following code in R

library(dplyr)
target_values = 1:9
max_score_to_win = 3
generate_possible_states = function(target_values)
{
   for (choose_num in 1:9)
   {
       states = data.frame(t(combn(1:9, choose_num)))
       if (choose_num == 1) { names(states) = "X1" }
       if(!exists("AllStates")) { AllStates = states } else { AllStates = bind_rows(AllStates, states) }
   }
   return(AllStates)
}
# Create list of all possible States

AllStatesList = generate_possible_states(target_values)
AllStatesList[is.na(AllStatesList)] = 999
AllStatesList$Open = paste(ifelse(AllStatesList$X1 == 999, "", AllStatesList$X1), 
                            ifelse(AllStatesList$X2 == 999, "", AllStatesList$X2), 
                           ifelse(AllStatesList$X3 == 999, "", AllStatesList$X3), 
                            ifelse(AllStatesList$X4 == 999, "", AllStatesList$X4), 
                           ifelse(AllStatesList$X5 == 999, "", AllStatesList$X5), 
                            ifelse(AllStatesList$X6 == 999, "", AllStatesList$X6), 
                           ifelse(AllStatesList$X7 == 999, "", AllStatesList$X7), 
                            ifelse(AllStatesList$X8 == 999, "", AllStatesList$X8), 
                           ifelse(AllStatesList$X9 == 999, "", AllStatesList$X9), sep = "")

In essence, columns X1 through X9 contain, in numerical order, the open boxes, with 999s being used to fill out these columns when fewer than 9 boxes are still open. We’ll call that a “state”. The column Open provides a useful shorthand for the contents of columns X1 to X9, ignoring any columns with 999. So, for example, a value of “12478” in Open is for the state where only boxes 1, 2 ,4, 7, and 8 remain open.

The rules of the game mean, however, that there are some states or combinations of boxes we can never face, specifically, those where we’ve already won the game on the previous roll, and those where we’ve apparently rolled a total of 1 with two dice.

The code to remove those (and, once done, to number all states) is:

# Remove impossible states
AllStatesList = AllStatesList %>% filter(!Open %in% c("1", "2", "3", "12", "23456789"))

# Sequentially number each state
AllStatesList$StateNum = paste("S", 1:nrow(AllStatesList), sep = "")

That leaves us with an AllStatesList dataframe containing 506 valid game states.

Next we need to perform step 2, which will associate each of these possible states with a set of possible box closures given a particular rolled total.

The code to this is:

generate_possible_moves = function(statenum, available_values, total_rolled)
{
  have_result = FALSE

  for (num_picked in 1:4)
  {
      combs <- data.frame(t(combn(available_values, num_picked)))
      out <- rowSums(combs)
      id <- which(out == total_rolled)

      if (length(id) != 0)
      {
         rows_to_add = combs[id,]
         rows_to_add$StateNum = statenum
         rows_to_add$TotalRolled = total_rolled

         if (num_picked == 1) { names(rows_to_add) = c("P1", "StateNum", "TotalRolled") }
         if (num_picked == 2) { names(rows_to_add) = c("P1", "P2", "StateNum", "TotalRolled") }
         if (num_picked == 3) { names(rows_to_add) = c("P1", "P2", "P3", "StateNum", "TotalRolled") }
         if (num_picked == 4) { names(rows_to_add) = c("P1", "P2", "P3", "P4", "StateNum", "TotalRolled") }
      }  

      if (length(id) != 0)
      {
         if(!exists("AllCombs")) { AllCombs = rows_to_add } else { AllCombs = bind_rows(AllCombs, rows_to_add) }
         AllCombs = as.data.frame(AllCombs)
         have_result = TRUE
      }   
   }   
   
   # Handle case with no possible moves
   if (have_result == FALSE) { AllCombs = data.frame(StateNum = statenum, TotalRolled = total_rolled, P1 = NA, P2 = NA, P3 = NA, P4 = NA) 
                             } else
                                  {
                                     if(length(AllCombs$P1) == 0) {AllCombs$P1 = NA}
                                     if(length(AllCombs$P2) == 0) {AllCombs$P2 = NA}
                                     if(length(AllCombs$P3) == 0) {AllCombs$P3 = NA}
                                     if(length(AllCombs$P4) == 0) {AllCombs$P4 = NA}
                                     
                                     AllCombs = AllCombs %>% select(StateNum, TotalRolled, P1, P2, P3, P4)
                                  } 
    
   AllCombs = as.data.frame(AllCombs)
   
   return(AllCombs)
}
#### Generate all Possible Moves for a Given State and Total
for (SN in unique(AllStatesList$StateNum))
{
   for (TotalRolled in 2:12)
   {
       PossibleMoves = generate_possible_moves(SN, unlist(AllStatesList[AllStatesList$StateNum == SN,1:9]), TotalRolled)
       
       if(!exists("AllPossibleMoves")) { AllPossibleMoves = PossibleMoves } else { AllPossibleMoves = bind_rows(AllPossibleMoves, PossibleMoves) }
   }
}

#### Combine them
GameSpace = left_join(AllStatesList, AllPossibleMoves, by = c("StateNum" = "StateNum"), multiple = "all")

After running this code we will now have, for every state that was originally in the AllStatesList dataframe, rows in a GameSpace dataframe for every possible dice total of 2 and 12 and the legal box closures that could be made given that roll (recorded in columns P1, P2, P3, and P4 where P1 is the lowest-numbered box we’re removing, P2 is the next-lowest if any, and so on, and NAs are used to show when there are no more picks. The sum of P1 to P4 will match the TotalRolled). When we’re done, the GameSpace dataframe will contain 8,607 rows, each of which we’ll call a strategy in that it is a legitimate move given the current state and the rolled total.

It’ll be convenient if we add two more items to this dataframe:

  • Columns that summarise the state after we have removed the boxes described in columns P1 to P4.

  • A column that allows us to group competing stategies - that is, those that could be chosen given the same state and the same rolled total. Imagine, for example, closing box 3 instead of boxes 1 and 2 if all were still open.

#### Determine end state after move
GameSpace$F1 = 0
GameSpace$F2 = 0
GameSpace$F3 = 0
GameSpace$F4 = 0
GameSpace$F5 = 0
GameSpace$F6 = 0
GameSpace$F7 = 0
GameSpace$F8 = 0
GameSpace$F9 = 0
GameSpace$Outcome = "Undetermined"

for (GS in 1:nrow(GameSpace))
{
   NewState = determine_new_state(GameSpace[GS, c("X1", "X2", "X3", "X4", "X5", "X6", "X7", "X8", "X9")], GameSpace[GS, c("P1", "P2", "P3", "P4")])
   
   GameSpace$F1[GS] = NewState[1]
   GameSpace$F2[GS] = NewState[2]
   GameSpace$F3[GS] = NewState[3]
   GameSpace$F4[GS] = NewState[4]
   GameSpace$F5[GS] = NewState[5]
   GameSpace$F6[GS] = NewState[6]
   GameSpace$F7[GS] = NewState[7]
   GameSpace$F8[GS] = NewState[8]
   GameSpace$F9[GS] = NewState[9]
   
   GameSpace$Outcome[GS] = ifelse(is.na(GameSpace$P1[GS]), "Loss", 
                             ifelse(ifelse(GameSpace$F1[GS] == 999, 0, GameSpace$F1[GS]) + 
                                     ifelse(GameSpace$F2[GS] == 999, 0, GameSpace$F2[GS]) + 
                                    ifelse(GameSpace$F3[GS] == 999, 0, GameSpace$F3[GS]) +  
                                     ifelse(GameSpace$F4[GS] == 999, 0, GameSpace$F4[GS]) <= max_score_to_win, "Win", GameSpace$Outcome[GS]))
}

# Add RivalGroup
GameSpace = GameSpace %>% group_by(Open, TotalRolled) %>% mutate(RivalGroup = cur_group_id())
GameSpace = GameSpace %>% group_by(RivalGroup) %>% mutate(StrategyCount = length(RivalGroup))
GameSpace$StrategyNum = 1:nrow(GameSpace)

After running this code, GameSpace will now have columns F1 to F9 performing the same function as columns X1 to X9 but reflecting the post roll and box closure position. It will also contain an Outcome column that tells us if the game has been won or lost, or is still undetermined.

Also it will have a RivalGroup column that links competing strategies.

The last thing to do is to look for Rival groups in which the outcomes are all wins, and then just (arbitrarily) keep the first strategy in the group. The code to this is as follows:

remove_redundancy = function(GS)
{
   for (RG in unique(GS$RivalGroup))
   {
       toss = -999
       
       Rivals = GS %>% filter(RivalGroup == RG)
       
       WinningStrategies = Rivals$StrategyNum[Rivals$Outcome == "Win"]
       
       if(length(WinningStrategies) > 1)
       {
          toss = WinningStrategies[-1]
       }  
        
       GS =  GS %>% filter(!StrategyNum %in% toss)
   } 
   return(GS)
}
# Remove redundant rows
GameSpace = remove_redundancy(GameSpace)

# Add Removed 
GameSpace = GameSpace %>% mutate(Removed = paste(ifelse(!is.na(P1), P1, ""),
                                                 ifelse(!is.na(P2), P2, ""),
                                                 ifelse(!is.na(P3), P3, ""),
                                                 ifelse(!is.na(P4), P4, ""), sep = ""))
##

write.csv(GameSpace, 'GameSpace.csv', row.names = FALSE)

Turns out there are only 8 redundant strategies (related to the situation where a player can remove 1 and 2, or just 3, and arrive at a win either way. This code for the function that does this feels ridiculously inefficient in identifying these strategies, but I’ll leave it an as exercise for readers to create their own, better, version.

As a final step we create a Removed column in GameSpace, that summarises the columns in P1 through P4 in much the same way that the Open column summarises columns X1 through X9. Creating these columns is solely for the purpose of making it visually easier to see what we have and what we remove by way of boxes in each strategy.

We end, then, with GameSpace containing 8,599 distinct strategies and, in Part 2, we’ll start to use this dataframe.