1
$\begingroup$

I am working on the Wolfram Challenge Babbage Squares. I have looked at the following resources in order to come up with an idea for how to find all the possible word squares:

I am going to exploit the following properties of a word square to my advantage.

  • It is symmetric. If it is a matrix, its transpose is equal to itself.
  • I only have to find word squares of length 4.
  • Wolfram Mathematica has 3 very helpful functions built-in: DictionaryWordQ, DictionaryLookup, and WordList.

I am still working on my program and will revisit this question to improve it over the next few days. My goal is to make a fast word square generation program to complete the Babbage Squares Problem. I have broken down my approach by first setting up a matrix

{{letter1, letter2, letter3, letter4}, {letter2, diagonalelement1, 
   symmetricelement1, symmetricelement2}, {letter3, symmetricelement1,
    diagonalelement2, symmetricelement3}, {letter4, symmetriclement2, 
   symmetricelement3, diagonalelement3}} // MatrixForm

I first decided to break down the problem into smaller steps. Suppose I want to find a word square from a two letter word. My square looks like this in grid form. I am using three different groups of variables: letters 1 through 4, diagonal elements 1 through 3, and symmetric elements 1 through 3. Square size 2 by 2

Grid[{{letter1, letter2}, {letter2, diagonalelement1}}]

For example, let's take a and t as the first two letters. We then find all words with letter2 and one other letter. We then use the Part function to obtain the 2nd character of each word and make a 2 by 2 word square for each case.

letter1 = "a"; letter2 = "t";
Grid[{{letter1, letter2}, {letter2, diagonalelement1}}]
DictionaryLookup[letter2 ~~ _]
Grid[{{letter1, letter2}, {letter2, #}}] & /@ 
 Characters[DictionaryLookup[letter2 ~~ _]][[All, 2]]

enter image description here enter image description here My next idea was to expand to a 3 by 3 word square. enter image description here

Grid[{{letter1, letter2, letter3}, {letter2, diagonalelement1, 
   symmetricelement1}, {letter3, symmetricelement1, 
   diagonalelement2}}]

I want to make use of the fact that I can exclude letters that are not part of four letter words, but for this example I am going to use only two letter words. A modified version that employs this fact to improve the efficiency of the algorithm is:

Select[Alphabet[], DictionaryLookup[letter2 ~~ # ~~ _ ~~ _] != {} &]

I use Select and pure functions to find what letters for symmetricelement1 are possible.

(x |-> Select[Alphabet[], 
    DictionaryLookup[letter2 ~~ x ~~ # ~~ _] != {} &]) /@ 
 Select[Alphabet[], DictionaryLookup[letter2 ~~ # ~~ _ ~~ _] != {} &]

The hard part is keeping track of which sublist is linked to which letter for diagonalelement1. I have two ideas to solve this problem:

  • Use nested a nested Association or List.
  • Use a functional approach with Apply @@ and @@@.

I am wondering how to overcome the expansion from 2 by 2 word squares to 3 by 3 word squares. I am actively working on this program and will update this question with ideas and information the next few days. My goal after I make the three by three square work is to build an efficient four by four word square algorithm. My code is here. I can create a function to implement a backtracking algorithm but I'm not sure how to implement a backtrack algorithm in Mathematica. I found a function through the Combinatoric package but don't want to have to import a package.

$\endgroup$

1 Answer 1

0
$\begingroup$

I have created an algorithm that takes about 2.4 seconds to find the word squares for "hair" and 10.5 seconds for "dogs".

BabbageSquares[word_String /; StringLength[word] == 4] := 
 Block[{c1, c2, c3}, c1 = StringPart[word, 2]; 
  c2 = StringPart[word, 3]; c3 = StringPart[word, 4]; 
  Grid[Characters /@ #] & /@ 
   Flatten[(Map[
       Function[w, 
        Join[{word}, 
           Join[w, #]] & /@ (StringCases[
            Select[WordList[], StringLength[#] == 4 &], 
            c3 ~~ StringPart[First[#], 4] &[w] ~~ 
                StringPart[Last[#], 4] &@w ~~ _] /. {} -> Nothing)], 
       Select[Tuples[{Flatten@
            StringCases[Select[WordList[], StringLength[#] == 4 &], 
             c1 ~~ _ ~~ _ ~~ _] /. {} -> Nothing, 
          Flatten@StringCases[
             Select[WordList[], StringLength[#] == 4 &], 
             c2 ~~ _ ~~ _ ~~ _] /. {} -> Nothing}], 
        StringPart[First[#], 3] == StringPart[#[[2]], 2] &]] /. {} -> 
       Nothing), 1]]

Revision: I have created a faster algorithm that runs in under 1 second for both "hair" and "dogs"

BabbageSquares[word_String /; StringLength[word] == 4] := 
 Block[{c1, c2, c3, wordlist}, 
  wordlist = 
   Select[Select[WordList[], StringLength[#] == 4 &], 
    StringMatchQ[#, LetterCharacter ..] &]; c1 = StringPart[word, 2]; 
  c2 = StringPart[word, 3]; c3 = StringPart[word, 4]; 
  Grid[Characters /@ #] & /@ 
   Flatten[DeleteCases[
     Map[Function[w, 
       Join[{word}, 
          Join[w, #]] & /@ (StringCases[wordlist, 
           c3 ~~ StringPart[First[#], 4] &[w] ~~ 
               StringPart[Last[#], 4] &@w ~~ _] /. {} -> Nothing)], 
      Select[Tuples[{Flatten@
           StringCases[wordlist, c1 ~~ _ ~~ _ ~~ _] /. {} -> Nothing, 
         Flatten@StringCases[wordlist, c2 ~~ _ ~~ _ ~~ _] /. {} -> 
           Nothing}], 
       StringPart[First[#], 3] == StringPart[#[[2]], 2] &]], {}], 1]]
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.