JUST SAYING puzzle

Question

The Sunday New York Times magazine has a new puzzle (June 26, 2022), JUST SAYING by Will Shortz, with the following rules:

• Change one letter in each word to spell a new word. Then arrange the new words to form a familiar proverb or saying. For example, given the words DOES, LIP, LOT, and SWEEPING, you could change them to DOGS, LIE, LET, and SLEEPING and then arrange them to spell "Let sleeping dogs lie."

I'd like code to take input of the form {"alive" ,"mines", "thick", "treat"} and return the puzzle solution ({"great minds think alike"}).

Here is (inefficient) code that returns valid English words that differ by exactly one letter from a given word:

f[myWord_String] := 
 Complement[
    Flatten@Select[(DictionaryLookup /@ (Flatten@
        Table[StringReplacePart[myWord, # , {i, i}] & 
          /@ CharacterRange["a", "z"], 
      {i, StringLength[myWord]}])), # != {} &] , {myWord}]

and thus

f["alive"]

(* {"alike", "olive"} *)

Thus f applied to a target puzzle gives:

wordsets = f /@ {"alive", "mines", "thick", "treat"}

(* {{"alike", "olive"}, {"dines", "fines", "kines", "lines", "manes", "mikes", "miles", "mimes", "minds", "mined", "miner", "minis", "minks", "mints", "minus", "mires", "mites", "mixes", "nines", "pines", "sines", "tines", "vines", "wines", "zines"}, {"chick", "think", "trick"}, {"great", "tread"}} *)

Now I can get a list of all possible scrambled sentences (one word from each word in the original puzzle):

theTuples =Tuples[wordsets]

For each scrambled sentence I can get them in all possible orders (which would include the grammatical, unscrambled, order... if possible):

thePerms = Permutations /@ theTuples

Now I can get all scrambled sentences (though one is not scrambled):

finalCandidates =StringJoin /@ (Riffle[#, " "] & /@ Flatten[thePerms, 1])

Then I hit a problem: How do I automatically select among these to find the sentence that is a familiar proverb or saying?

I've tried some simple grammatical tests, using TextStructure and "Sentence", of this form:

    Select[finalCandidates, 
     StringContainsQ[
      TextStructure[#, "ConstituentStrings"], "Sentence"][[1]] &]

but it gives lots and lots of candidate "sentences," most of which are not true grammatical or sensible sentences.

For those interested, here are three (of 24) of the puzzles in this Sunday's Times so you can test your code:

• {"deer", "rue", "stile", "wafers"}
• {"ell","heads","mounds","tile"}
• {"lute","newer","setter","thaw"}

It would be nice to get highly optimized/elegant code (fewest characters), but that isn't necessary.

Answer 1

The main part of solving this is having a database of English proverbs, I used the Oxford Dictionary of Proverbs which contains almost 2000 records, and phrases.org.uk which contains 680. Because of my almost SameAs[0] (need 13.1 :) knowledge of Copyright, I won't post the file.

Assume I have a file that contains around 2800 (with some duplicates), each line is a proverb:

data = ToLowerCase @ Import["C:\\english proverbs.txt", "List"];

Thanks to your f function, we have all the possible words. The only thing left is finding the corresponding row, which in this case, I think RegularExpression would be a good choice:

ClearAll[findProverb];

findProverb[words_] := Block[{wordsets = f /@ ToLowerCase[words]},
  SelectFirst[data, 
    StringMatchQ[(StringExpression @@ 
         Riffle[#, " "]) & /@ (Alternatives @@ 
        Permutations[Alternatives @@@ wordsets])], None] // AbsoluteTiming
  ]

Example

I used two AbsoluteTiming to show how much it's efficient and by you improving your f function, this would also speed up. The first time is for the whole operation, second for matching to the database:

findProverb[{"alive", "mines", "thick", "treat"}] // AbsoluteTiming

(* Out: {0.029573, {0.0023431, "great minds think alike"}} *)


findProverb[{"DOES", "LIP", "LOT", "SWEEPING"}] // AbsoluteTiming

(* Out: {0.02505, {0.0005505, "let sleeping dogs lie"}} *)


findProverb[{"deer", "rue", "stile", "wafers"}] // AbsoluteTiming

(* Out: {0.0370255, {0.0093319, "still waters run deep"}} *)


findProverb[{"ell", "heads", "mounds", "tile"}] // AbsoluteTiming

(* Out: {0.0495492, {0.0217548, None}} *)


findProverb[{"lute", "newer", "setter", "thaw"}] // AbsoluteTiming

(* Out: {0.0395115, {0.0120382, "better late than never"}} *)

By extending your database to cover more proverbs, you won't see None.

Update 1

Since we'll search the database, it doesn't matter to find the possible words, if we consider that changing letter in our searching. We could further optimize the function without using f!

This only changes the wordsets definition:

ClearAll[findProverb2];

findProverb2[words_] := 
 Block[{wordsets = StringReplaceList[ToLowerCase[words], WordCharacter -> _]},
  SelectFirst[data, 
    StringMatchQ[(StringExpression @@ 
         Riffle[#, " "]) & /@ (Alternatives @@ 
        Permutations[Alternatives @@@ wordsets])], None] // AbsoluteTiming
  ]

Using RepeatedTiming on the examples yields around (4, 25, 14, 0.97, 1.7) times difference. The 0.97 one is because thanks to @ubpdqn I added it to the end of the file, so both algorithms should reach the end of the file to return. In general, it's faster and shorter ;)