Solution #2

• Generate all possible expression trees
• Build up expressions from the leaves, doing simple evaluations at each node
• i.e. Never try and evaluate the full expression from scratch - always evaluate it as a simple operation of the values returned in the subtrees.
• Uses memoisation to cache the results of subtrees so that similar subtrees are only ever evaluated once.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate and evaluate all possible expressions from the given numbers
#
# @param nums vector of integers
# @param integer_only only generate integer solutions?  default: TRUE
# 
# @return list with 2 elements. 'exprs' which is the character vector of all
#         possible expressions.  'values' which is the numeric vector of the
#         evaluation of each of those expressions
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
generate_exprs_ <- function(nums, integer_only = TRUE) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Recursive function termination condition - only 1 number given
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (length(nums) == 1L) {
    return(list(exprs = as.character(nums), values = nums))
  } 
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # For the given length of 'nums', what are all the possible ways
  # we could split these numbers into 2 groups?
  # See appendix for definition
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  splits <- all_splits[[length(nums)]]
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # This is where I'll be storing the solutions
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  exprs  <- character(0)
  values <- numeric(0)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Evaluate every possible combination of numbers for every possible 
  # arithmetic op.  For non-commutative operations, need to evaluate a second
  # time with arguments in reverse order
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (split in splits) {
    
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Generate all the possible subtrees from this node
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    lhs <- generate_exprs(nums[split[[1]]], integer_only) # use memoised version
    rhs <- generate_exprs(nums[split[[2]]], integer_only) # use memoised version
    
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Build the expression string for each possible combination of 
    # left and right expression subtrees
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    L <- rep(lhs$exprs, times = length(rhs$exprs))
    R <- rep(rhs$exprs, each  = length(lhs$exprs))
    exprs <- c(
      exprs,
      paste0("(", L, " - ", R, ")"),
      paste0("(", L, " / ", R, ")"),
      paste0("(", L, " + ", R, ")"),
      paste0("(", L, " * ", R, ")"),
      paste0("(", R, " - ", L, ")"),
      paste0("(", R, " / ", L, ")")
    )
    
    
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Perform each possible operation on each possible combination of 
    # left and right value subtrees
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    L <- rep(lhs$values, times = length(rhs$values))
    R <- rep(rhs$values, each  = length(lhs$values))
    values<- c(
      values,
      L - R,
      L / R,
      L + R,
      L * R,
      R - L,
      R / L
    )
  }
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Filter solutions to only keep unique solutions.
  # Filter out non-integer solutions if requested.
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (integer_only) {
    accept <- !duplicated(exprs) & is.finite(values) & values == round(values)
  } else {
    accept <- !duplicated(exprs)
  }
  
  list(exprs=exprs[accept], values=values[accept])
} 



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Memoise the generation of expressions for any list of numbers
# This eliminates having to ever calculate the expressions for the same list
# of numbers a second time.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
generate_exprs <- memoise::memoise(generate_exprs_)



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Recursively generate all possible expressions for a set of numbers.
#
# For a given list of numbers, generate all expressions for these numbers
# and all possible sub-sets of these numbers. this way if nums = c(1, 3, 4)
# and target = 12, the solutions will include (1 * 3 * 4) as well as (3 * 4)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
generate_all_exprs <- function(nums, integer_only = TRUE) {
  
  exprs  <- character(0)
  values <- numeric(0)
  
  if (length(nums) == 1L)  {
    return(list(exprs = as.character(nums), values = nums))
  }
  
  nums <- sort(nums)
  
  # Solve the sub-problems
  for (i in seq_along(nums)) {
    this_res <- generate_all_exprs(nums[-i], integer_only)
    exprs    <- c(exprs , this_res$exprs )
    values   <- c(values, this_res$values)
  }
  
  # Solve this problem
  this_res <- generate_exprs(nums, integer_only)
  exprs    <- c(exprs , this_res$exprs )
  values   <- c(values, this_res$values)
  
  
  accept <- !duplicated(exprs)
  
  list(exprs = exprs[accept], values = values[accept])
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Solve the countown problem
#
# Generate all possible expressions with an integer result and then filter
# only for those which evaluate to the target number
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
solve_countdown <- function(nums, target) {
  res <- generate_all_exprs(sort(nums), integer_only = TRUE)
  res$exprs[res$values == target]
}

generate_all_exprs(1:2)

## $exprs
## [1] "2"       "1"       "(1 - 2)" "(1 + 2)" "(1 * 2)" "(2 - 1)" "(2 / 1)"
## 
## $values
## [1]  2  1 -1  3  2  1  2

generate_all_exprs(1:2, integer_only = FALSE)

## $exprs
## [1] "2"       "1"       "(1 - 2)" "(1 / 2)" "(1 + 2)" "(1 * 2)" "(2 - 1)"
## [8] "(2 / 1)"
## 
## $values
## [1]  2.0  1.0 -1.0  0.5  3.0  2.0  1.0  2.0

system.time({
  nums   <- c(50, 9, 4, 5, 9, 3)
  target <- 952
  res    <- solve_countdown(nums, target)
})

##    user  system elapsed 
##   6.800   0.401   7.218

system.time({
  target <- 404
  nums   <- c(1, 1, 1, 1, 1, 100)
  res    <- solve_countdown(nums, target)
})

##    user  system elapsed 
##   1.204   0.120   1.346

res

## [1] "((1 + 1) * ((1 + 1) * (1 + 100)))" "((1 + 1) * ((1 + 100) * (1 + 1)))"
## [3] "((1 + 100) * (1 + (1 + (1 + 1))))" "((1 + 100) * ((1 + 1) + (1 + 1)))"
## [5] "((1 + 100) * ((1 + 1) * (1 + 1)))"

Summary

• Can generate all possible simple arithmetic expressions for 6 numbers in around ~10 seconds (if we limit the results such that must be an integer).
• If we allow all floating point and NA/Inf expressions, then full generation of all arithmetic expressions for 6 numbers takes about < 1 minute.

Appendix

all_splits

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Split 'n' indices into all possible 2 group combinations 
# with 'ngroup' numbers in the first group
#
# @param n maximum index. 
# @param ngroup number of indices in the first group
# @return list of lists. each innermost list has 2 vectors of disjoint indicies
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
split_sets <- function(n, by) {
  mat <- combn(seq(n), by)
  if (by == n/2) {
    mat <- mat[, seq(ncol(mat)/2), drop = FALSE]
  }
  
  res <- apply(mat, 2, list)
  res <- lapply(res, function(x) {list(x[[1]], setdiff(seq(n), x[[1]]))})
  res
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate all possible split sets for the given n
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
all_split_sets <- function(n) {
  nn <- n - 1
  nn <- min(floor(n/2), n-1)
  seq(nn) %>% 
    purrr::map(~split_sets(n, by = .x)) %>%
    unlist(recursive = FALSE)
}


all_splits <- 1:6 %>% purrr::map(all_split_sets)