Solve the Puzzle

Much of the grunt work is done by the wfinder package, which generates a word list from an aribtrary set of letters, as in Scrabble. Unlike Scrabble, we CAN reuse the same letter more than once. This package also contains a list of English words we use. You can substitute any word list you like, in any language. My Mom, whose native language was German, was the champion in our family. I always struggled even though I liked to brag about my high SAT verbal score. I am grateful to Mom for knocking me down a peg. Anyhoo, I am really in awe of the power of the grep function. Regexes are a dark art to me. The idea that a short line could find every possible word in an instant boggles (don’t like that game either) the mind. Suppose you pull the Scrabble tiles “ABAHRTY”.

grep("^[abahrty]*$",word_list,value = T)
##   [1] "aa"       "aah"      "ab"       "aba"      "abaya"    "abb"     
##   [7] "abba"     "abray"    "aby"      "ah"       "aha"      "ahh"     
##  [13] "ar"       "araba"    "arar"     "arb"      "arba"     "arhat"   
##  [19] "arrah"    "array"    "art"      "arty"     "ary"      "at"      
##  [25] "atar"     "att"      "attar"    "ay"       "ayah"     "ba"      
##  [31] "baa"      "baba"     "baby"     "bah"      "baht"     "bar"     
##  [37] "barb"     "barra"    "barrat"   "barratry" "baryta"   "bat"     
##  [43] "batata"   "bath"     "batt"     "batta"    "batty"    "bay"     
##  [49] "bayt"     "bra"      "brat"     "bratty"   "bray"     "brr"     
##  [55] "brrr"     "by"       "ha"       "haar"     "hah"      "haha"    
##  [61] "harry"    "hart"     "hat"      "hath"     "hay"      "rabat"   
##  [67] "rah"      "rat"      "rata"     "ratatat"  "rath"     "ratty"   
##  [73] "ray"      "raya"     "rayah"    "rhy"      "rhyta"    "rya"     
##  [79] "rybat"    "ta"       "tab"      "tabby"    "taha"     "tahr"    
##  [85] "tar"      "tara"     "tarry"    "tart"     "tartar"   "tarty"   
##  [91] "tat"      "tatar"    "tath"     "tatt"     "tatty"    "tay"     
##  [97] "tayra"    "thar"     "that"     "thy"      "trat"     "tratt"   
## [103] "tray"     "try"      "ya"       "yabby"    "yah"      "yar"     
## [109] "yarr"     "yarta"    "yatra"    "yay"

112 words out of a corpus of over 260 thousand. Instantly. That’s all the code it takes? That’s nuts! That’s efficient low-level coding. wfindr wraps that bit of magic with some bells and whistles to aid with word puzzles. In particular it crafts regexes that conform to the rules of scrabble. The example above creates a word list that might use more of a letter than we have in our tiles. To fix that, the simple regex I show above gets converted to a much fancier one.

model_to_regex(allow="abahrty",type="scrabble")
## [1] "(?=^((([^a]*a[^a]*){1,2})|([^a]*))$)(?=^((([^b]*b[^b]*){1,1})|([^b]*))$)(?=^((([^h]*h[^h]*){1,1})|([^h]*))$)(?=^((([^r]*r[^r]*){1,1})|([^r]*))$)(?=^((([^t]*t[^t]*){1,1})|([^t]*))$)(?=^((([^y]*y[^y]*){1,1})|([^y]*))$)^[abhrty]*$"

Whoa! Like I said. It’s regex is a dark art.

Now we have all the possible words to use in the puzzle. Just throwing random words around from the solution set would eventually find some answers but we can do much better than that. To find the “best” next word, we can pick the word that has the most yet-unused letters. By default, the function below returns one word but it could return more. In practice, I found iterating through more words was rarely necessary to get a solution but drastically increased computation time and memory usage of the recursive function that calls it.

find_next_best_words <- function(w,needed_letters,max_return=1){
  # the higher max_return is the more words will be traversed.  Careful,
  # computation times will geometrically increase.
  # puzzle_words is global
  # find words that start with last letter of w
  next_words<-puzzle_words[str_starts(puzzle_words,str_sub(w,-1))]
  # prioritize words by greatest overlap with unused letters
  next_word_chars <-  map(next_words,strsplit,split="") %>% unlist(recursive = F)
  temp <- map(next_word_chars,function(x) length(setdiff(needed_letters,x))) %>% unlist()
  if (is.vector(temp)){
    next_words <- next_words[order(temp)]
    max_return <- min(length(next_words),max_return)
    return(next_words[1:max_return])  
  } else{
    return()
  }
}
# -----------------------------------------------------
# check if we have used all the letters yet
test_needed_letters <- function(word_chain){
  word_chain_chars <-  paste0(word_chain,collapse = "") %>% 
    strsplit(split="") %>%
    unlist() %>% 
    unique()
  return(setdiff(all_puzzle_letters,
                     word_chain_chars))
}

Now we come to the workhorse recursive function. “Recursive” just means it calls itself. I’ve learned the trick to recursive functions is getting out of them, otherwise you get deeper and deeper into the “Beyond” section of “Bed, Bath and Beyond” and run out of memory pretty quickly. At least nowadays you kids don’t have to worry about the whole machine crashing. You can just nuke the process that’s stuck.

We start by preparing to iterate make_chain over the full list of valid words. Naturally we expect to find a solution before traversing much of the list. We build the solution chain by choosing a word that ends with a letter that has not been an ending letter yet. Otherwise we might chase our tail forever if a solution doesn’t lie on that path. Then we pick the best next word as described above. Then we call make_chain again and again and again.

Here we limit the solution chain to a maximum of five words. Each time make_chain is called we run some tests and climb back out of the recursive stack if one of these conditions has been met:

1. The chain is more than five words with no solution.
2. A solution is found.
3. We run out of last letter/first letter possibilities
4. The are no next words found.

make_chain <- function(word_chain,used_last_letters){
  needed_letters <- test_needed_letters(word_chain)
  if (length(word_chain)>6){
    # Come on, if you can't solve in 5 words, you suck!
    return()
  }
  if (length(needed_letters)==0) {
    # Yay! We have a solution.
    return(list(word_chain))
  }
  else {
    last_word <- tail(word_chain,1)
    last_letter <-str_sub(last_word,-1L)
    if (str_detect(used_last_letters,last_letter,negate=T)){
      used_last_letters <- paste0(last_letter,used_last_letters,collapse = "")
      next_word<-find_next_best_words(last_word,needed_letters,max_return=1)
       if (length(next_word)>0){
        word_chain <- make_chain(c(word_chain,next_word),used_last_letters)
        } else {
          # no next word found
          return()
        }
    } else{
      # start of next word would be a letter that has already been used
      return()
    }
  }
} 

The function solve_puzzle is a wrapper around make_chain that first gets all the possible words that our letters allow, removing words that violate the rule of no consecutive letters from the same line. Note the use of the <<-- assignment operator that accesses global variables from within functions. This practice is frowned upon in some circles but, since we are using nested recursion, I didn’t want to make new copies of every variable each time make_chain is called.

# dplyr chain-friendly permuatations
d_permute <- function(v, n, r,  set, repeats.allowed){
  return(permutations(n, r, v, set, repeats.allowed))
}

get_line_combos <- function(a_side,puzzle){
  combos <- puzzle %>% filter(side==a_side) %>% 
    pull(letter) %>% 
    as.character() %>% 
    d_permute(n=3,r=2,set=F,repeats.allowed = T) %>% 
    apply(1,paste0,collapse="")
  return(combos)
}


solve_puzzle <- function (puzzle) {
  # get all letter combos that are invalid because they lie on the same line segment
  bans <- map(1:sides,get_line_combos,puzzle=puzzle) %>% unlist()
  #get all possible words
  puzzle_words <<- scrabble(paste0(puzzle$letter,collapse = ""),words=word_list)
  length(puzzle_words)
  #winnow out illegal ones
  banned_words <- map(bans,function(x) puzzle_words[str_which(puzzle_words,x)]) %>% 
    unlist()
  puzzle_words <<- puzzle_words[!(puzzle_words %in% banned_words)]
  length(puzzle_words)
  puzzle_words <<-puzzle_words[order(nchar(puzzle_words),decreasing = TRUE, puzzle_words)]
  
  
  all_puzzle_letters <<- puzzle$letter %>% as.vector()
  
  solutions <- map(puzzle_words,make_chain,"") %>% unlist(recursive = F)
  return(solutions)
}

Whew! Now let’s actually solve a puzzle. The solve_puzzle function returns a list of lists with all the found solutions.

vowel_count <- sides
# global variables
all_puzzle_letters <- NULL
puzzle_words <- NULL
puzzle <- generate_puzzle(sides=sides,
                          letters_per_side = letters_per_side,
                          vowel_count = vowel_count)
# add letter coordinates for plot
puzzle <- get_letter_coords(puzzle,
                            sides=sides,
                            letters_per_side = letters_per_side)
#draw_puzzle(puzzle)
solutions <- solve_puzzle(puzzle)

solutions %>% head()
## [[1]]
## [1] "vortical" "loamy"    "yuca"     "aimful"  
## 
## [[2]]
## [1] "voracity" "ymolt"    "trayful" 
## 
## [[3]]
## [1] "foulmart" "trifoly"  "yuca"     "avoutry" 
## 
## [[4]]
## [1] "vacuity" "ymolt"   "trifoly"
## 
## [[5]]
## [1] "trayful" "lorica"  "avoutry" "ymolt"  
## 
## [[6]]
## [1] "flavory" "ymolt"   "toluic"

We may have hundreds of solutions or none. You can look at the solutions variable to see all we found. The goal of The Times puzzle is to solve in the minimum number of words so we’ll take the solution with the least number of words (there may be many) and print that on the puzzle.

# ---------------------------------------------------------
draw_solution <- function(puzzle, solutions){
  if (is.null(solutions)) {
    solution <- "No Solution"
  } else {
    ideal <- map(solutions,length) %>% unlist() %>% which.min()
    solution <- c(solutions[[ideal]],paste(length(solutions)-1,"other solutions")) 
  }
  gg <- draw_puzzle(puzzle)
  gg <- gg + annotate("text",x=0,y=0.9,label=paste(solution, collapse = "\n"), size = 6)
  print (gg)
}

draw_solution(puzzle, solutions)

Let’s go back to the image at the top of this post which is from The Times. We’ll use those letters to solve an actual puzzle. Do the puzzle authors generate the puzzles randomly or do they work backword from a selected word list? I have no idea.

sample_letters <- "taperdnilyco"
puzzle <- generate_puzzle() %>% get_letter_coords()
#replace random letters with the one in the known puzzle
puzzle$letter <- strsplit(sample_letters,split = NULL) %>% unlist()
solutions <- solve_puzzle(puzzle)
solutions %>% head()
## [[1]]
## [1] "lectionary" "yealdon"    "noplace"   
## 
## [[2]]
## [1] "centroidal" "lectionary" "yipe"      
## 
## [[3]]
## [1] "rantipole" "etypical"  "leporid"  
## 
## [[4]]
## [1] "planetoid" "dielytra"  "article"  
## 
## [[5]]
## [1] "placitory" "yealdon"  
## 
## [[6]]
## [1] "clarionet" "torpidly"

We found 851 solutions to this particular puzzle, quite a few. Furthermore, If you are really good, you could solve this puzzle with two words!

draw_solution(puzzle, solutions)

There you have it. You might grumble that too many of the words in the scrabble dictionary are not in your vocabulary. They certainly aren’t in mine. Feel free to use a shorter word list with more common words. Here are a bunch. That will increase the liklihood that no solution is found, though.

Further work that might be done would be to filter for completely unique solutions, with no overlapping words. Also we might create a Shiny application that does pretty animation drawing lines across the puzzle of the solution.

Naturally, you should only use this code to check your answer. No cheating!