8 out of 10 cats does countdown

Finding all solutions by recursive backtracking

My solution:

• Build every possible expression by nesting from right-to-left/inner-to-outer sub-expressions
• Abandon the expression early if it ever evaluates to a result that is not an integer
• Takes ~5 seconds to find all solutions to a puzzle from Countdown
• The code is on github if you felt like having a go.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Inner recursive routine for solving Countdown numbers puzzle
#'
#' @param nums What numbers are left to select from?
#' @param value the current calculated value
#' @param expr the current readable expression
#' @param verbose output solutions as they are found? default: FALSE
#'
#' @return Character vector of solutions if any are found, otherwise NULL
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
solve_inner <- function(nums, value, expr = value, target, verbose = FALSE) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Recursion termination conditions:
  #  1 -  Target number has been achieved
  #  2 -  Target number not achieved, and no more numbers to use
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (value == target) {
    if (verbose) {
      cat(expr, "\n")
    }
    return(expr)
  } else if (length(nums) == 0L) {
    return()
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # 'all_res' will accumulate all solutions
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  all_res <- c()
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Generate all possible arithmetic expressions from the current state
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (op in c('+', '-', '*', '/')) {
    for(num_idx in seq_along(nums)) {
      
      #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      # Evaluate expression, and if it's still an integer result, then recurse
      #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      new_value <- switch(
        op,
        '+' = nums[num_idx] + value,
        '-' = nums[num_idx] - value,
        '*' = nums[num_idx] * value,
        '/' = ifelse(nums[num_idx] %% value == 0L, nums[num_idx] %/% value, NA_integer_)
      )
      
      if (!is.na(new_value)) {
        res <- solve_inner(
          nums    = nums[-num_idx], 
          value   = new_value, 
          expr    = paste("(", nums[num_idx], ' ', op, ' ', expr, ")", sep = ''),
          target  = target,
          verbose = verbose
        )
        if (!is.null(res)) { all_res <- c(all_res, res) }
      }    
      
      #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      # For non-commutative operations, also recurse with arguments swapped
      #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      if (op %in% c('-', '/')) {
        new_value <- switch(
          op,
          '-' = value - nums[num_idx],
          '/' = ifelse(value && nums[num_idx] == 0L, value %/% nums[num_idx], NA_integer_)
        )
        
        if (!is.na(new_value)) {
          res <- solve_inner(
            nums    = nums[-num_idx], 
            value   = new_value, 
            expr    = paste("(", expr, ' ', op, ' ', nums[num_idx], ")", sep = ''),
            target  = target,
            verbose = verbose
          )
          if (!is.null(res)) { all_res <- c(all_res, res) }
        }    
      }
    } # num_idx loop
  }   # op loop
  
  all_res 
}




#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Solve the countdown numbers puzzle for the given set of numbers and target
#'
#' @param nums integer vector
#' @param target target number (integer)
#' @param verbose output solutions as they are found? default: FALSE
#'
#' @return Character vector of solutions if any are found, otherwise NULL
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
solve_countdown <- function(nums, target, verbose = FALSE) {
  nums   <- as.integer(nums)
  target <- as.integer(target)
  seq_along(nums) %>% 
    purrr::map(~solve_inner(nums[-.x], value = nums[.x], target = target, verbose = verbose)) %>%
    purrr::flatten_chr() %>%
    unique()
}

A small example

nums   <- c(2, 3, 4, 5)
target <- 11 
solve_countdown(nums, target)

##  [1] "(5 + (4 + 2))"       "(4 + (5 + 2))"       "(5 + (3 * (4 - 2)))"
##  [4] "(5 - (3 * (2 - 4)))" "(5 + (3 * 2))"       "(3 + (4 * 2))"      
##  [7] "((4 + (5 * 2)) - 3)" "(4 - (3 - (5 * 2)))" "(4 + ((5 * 2) - 3))"
## [10] "(5 + (3 * (4 / 2)))" "(5 + (2 * 3))"       "((5 * 3) - 4)"      
## [13] "(5 + (2 + 4))"       "(2 + (5 + 4))"       "(3 + (2 * 4))"      
## [16] "(4 + (2 + 5))"       "(2 + (4 + 5))"       "((4 + (2 * 5)) - 3)"
## [19] "(4 - (3 - (2 * 5)))" "(4 + ((2 * 5) - 3))" "((3 * 5) - 4)"

An example from the show

This is the example from the show at the top of this post. The second solution in the results matches the answer given on the show.

Finding all solutions takes about 5 seconds on my machine.

nums   <- c(50, 9, 4, 5, 9, 3)
target <- 952 
solve_countdown(nums, target)

##  [1] "((5 * ((4 * 50) - 9)) - 3)"       "(4 * (((5 * 50) - 9) - 3))"      
##  [3] "(((4 * ((5 * 50) - 9)) - 9) - 3)" "(((4 * ((5 * 50) - 9)) - 3) - 9)"
##  [5] "(4 * (((5 * 50) - 3) - 9))"       "(4 * ((3 * (9 * 9)) - 5))"       
##  [7] "(4 * ((9 * (5 + (3 * 9))) - 50))" "(4 * ((9 * (3 * 9)) - 5))"       
##  [9] "((5 * ((50 * 4) - 9)) - 3)"       "(4 * (((50 * 5) - 9) - 3))"      
## [11] "(((4 * ((50 * 5) - 9)) - 9) - 3)" "(((4 * ((50 * 5) - 9)) - 3) - 9)"
## [13] "(4 * (((50 * 5) - 3) - 9))"       "(4 * ((9 * (5 + (9 * 3))) - 50))"
## [15] "(4 * ((9 * (9 * 3)) - 5))"

An impossible puzzle

Sometimes the target number is impossible to achieve

solve_countdown(c(50, 2, 6, 5, 1, 5), 959)

## character(0)