2
$\begingroup$

One of the equations I work with in my research are the pentagon equations:

F[a,b,r,e,p,s]*F[p,c,d,e,q,r] == Sum[(F[b,c,d,s,x,r]*F[a,b,c,q,p,x]*F[a,x,d,e,q,s],{x,1,n}]

where a,b,c,d,e,p,q,r,s,x are indices of which the symbol is free to choose. Remembering such an equation would be much easier if these indices would be letters such that the strings p,c,d,e,q,r,a,b,r,e,p,s, etc would be words. For example if I chose the the letters d,o,a,t,i,e,n,g,s instead of a,b,c,d,e,p,q,r,s then the pentagon equations would become

F[d,o,g,i,e,s] F[e,a,t,i,n,g] = (a mess)

and thus the left hand side would be easy to remember (the RHS is still horrible though).

Saddly, there are no pairs of 6 letter words for which both the LHS and RHS are nice. I could of course allow for more freedom and demand that {a,b,r,e,p,s,p,c,d,e,q,r,b,c,d,s,x,r,a,b,c,q,p,x,a,x,d,e,q,s} (All indices written after each) other forms a list of words that may have different length. This looks a lot like a cryptography problem, but my knowledge of cryptography is kind of non-existing.

So the question is: how would one use Mathematica to find characters a,b,c,d,e,p,q,r,s,x, such that the list of characters above would become a list of words?

Undoubtly there will be many solutions but a few would suffice (one is already amazing, but if more can be found that would be great).


The code I used to find 5 6-letter words that match the pattern of the pentagon indices is the following (Though I doubt that it will be of much use):

(* List of 6 letter words with distinct characters *)
wordList = 
  DictionaryLookup[
    a_ ~~ b_ ~~ r_ ~~ e_ ~~ p_ ~~ s_ /; 
    DuplicateFreeQ[ ToLowerCase @ {a, b, r, e, p, s} ] 
  ];

(* Create pairs of words that match the indices of LHS *)
wordPairs1[ wordList_, str_String ]:=Module[{
  chars = Characters[str],
  a,b,c,d,e,p,q,r,s},
  {a,b,r,e,p,s} = chars;
  {str,#} & /@
  Cases[
    wordList,
    S_String/;
    StringMatchQ[ S, p~~c_~~d_~~e~~q_~~r /; DuplicateFreeQ[ToLowerCase@{a,b,c,d,e,p,q,r,s}]]
  ]
]

(* Finds 5 words whose letters match the indices of the equation *)
wordQuintuples[ wordList_][ { str1_String, str2_String } ] := Module[{
firstMatches, a, b, c, d, e, p, q, r, s, properStrings, 
  lowerWords = ToLowerCase[wordList] },
  {a,b,r,e,p,s} = Characters[str1];
  {p,c,d,e,q,r} = Characters[str2];
  firstMatches = 
    Cases[ 
      wordList, 
      S_String /; 
      StringMatchQ[ 
        S, 
        b~~c~~d~~s~~x_~~r /; 
        DuplicateFreeQ[ ToLowerCase@{a,b,c,d,e,p,q,r,s,x} ] 
    ]
  ];
  properStrings[ str_String ] := With[{
    x = Characters[str][[5]],
    s1 = ToLowerCase[StringJoin[a,b,c,q,p,Characters[str][[5]]]], 
    s2 = ToLowerCase[StringJoin[a,Characters[str][[5]],d,e,q,s]]
    },
    If[ 
      MemberQ[ lowerWords, s1 ] && MemberQ[ lowerWords, s2 ],
      {str1,str2,str,s1,s2},
      {}
    ]
  ];
  DeleteCases[{}] @ (properStrings /@ firstMatches)
]

The result is that there exists no letters for the indices that give nice 6 letter words for all factors.

$\endgroup$
1
  • $\begingroup$ Perhaps it would be easier to use sentences as mnemonics, with words starting with the letter of interest, Example (not an easy one. Ideally, the five sentences should tell a story): F[a,big,reader,enjoys,playing,sax]*F[playing,cop,does,entail,questioning,readers==F[big,cop,does,six,xerox,readers]*F[a,big,cop,questions,playing,xerox]*F[a,xerox,does,entail,questioning,Sax] $\endgroup$ – Jean-Pierre Feb 25 at 17:27
0
$\begingroup$

You could use WordList to get words for your pattern.

E.g. for your example:F[a,b,r,e,p,s]*F[p,c,d,e,q,r]. We must first get a list of words with 6 characzers:

words = Select[WordList["KnownWords", IncludeInflections -> True], 
   StringLength[#] == 6 &] // ToLowerCase;

Now we select words that correspond to the pattern: F[a,b,r,e,p,s]:

Select[t, 
 StringMatchQ[#, 
   StringExpression[a_, b_, r_, e_, p_, s_] /;  a != b != r != e != p != s] &]

(* {"abduce", "abduct", "abhors", "abides", "abient", "abject", \
"abjure", "ablest", "ablism", "abodes", "abohms"...} *)

Now assume we choose "abduc" and need a word for F[p,c,d,e,q,r]. Because of F[a,b,r,e,p,s] the symbols p,e,r already have values of "u","d","b" so the search pattern is:

Select[t, 
 StringMatchQ[#, StringExpression["u", c_, d_, "d", q_, "b"] /;  FreeQ[{"u", "d", "b"}, c | d | q]] &]

This does not find any word. Therefore we need to try another word, e.g. "abduct". I leave this search to you. Of course, one may also automate this, but I think it is not worth the time.

$\endgroup$
0
$\begingroup$

Spoiler Alert: There is no word that can have meaning in 5 different orders.

Workflow

After ordering the characters, you will get this:

(* string you want *)
s1, s2, s3, s4, s5, s6, s7, s8, s9, s10


F[s1,s2,s8,s5,s6,s9], F[s6,s3,s4,s5,s7,s8]

F[s2,s3,s4,s9,s10,s8], F[s1,s2,s3,s7,s6,s10], F[s1,s10,s4,s5,s7,s9]

Print the numbers via NumberLinePlot to help you build the solution:

NumberLinePlot[{{1, 2, 8, 5, 6, 9}, {6, 3, 4, 5, 7, 8}, {2, 3, 4, 9, 10, 8}, {1, 2, 3, 7, 6, 10}, {1, 10, 4, 5, 7, 9}}]

enter image description here

  • Since there are no 2 rows that cover all letters, I pick yellow, blue and green rows in order to find words (you can choose any combination as long as it covers all letters) like:

enter image description here

1- Create a list of 6 unique letter (using DuplicateFreeQ) words. I pick yellow row from above plot and find words base on that:

yellowWords = DictionaryLookup[
   x__ /; StringLength[x] == 6 && 
     DuplicateFreeQ@ToLowerCase@Characters[x]];

(*Output Length: 5049 *)

2- Define a function that finds blue words from given yellow word (base on the intersection of yellow and blue row from the plot):

findBlueWords[yellowWord_] := 
  Select[DictionaryLookup[
    StringExpression[_, _, #1, #2, #3, _] & @@ 
     StringPart[yellowWord, {3, 4, 6}], IgnoreCase -> True], 
   DuplicateFreeQ@ToLowerCase@Characters@# &];

3- Define another function to find green word from given yellow and blue words:

findGreenWords[yellowWord_, blueWord_] := 
  Select[DictionaryLookup[
    StringExpression[#1[[1]], #2[[1]], #2[[2]], #1[[2]], #1[[3]], _] \
& @@ {StringPart[blueWord, {2, 5, 6}], 
      StringPart[yellowWord, {1, 2}]}, IgnoreCase -> True], 
   DuplicateFreeQ@ToLowerCase@Characters@# &];

4- Map functions to yellow words with a little bit of tweaking:

result = Flatten[
  Tuples[{{#[[1, 1]]}, {#[[1, 2]]}, #[[2]]}] & /@ ({#, 
       findGreenWords @@ #} & /@ 
     Flatten[Tuples[{{#[[1]]}, #[[2]]}] & /@ 
       Map[{#, findBlueWords[#]} &, yellowWords], 1]), 1]
  • in step 4 you will find letters that meet 3 of your 5 criteria, like:
 {..., {"inroad", "strode", "tinder"}, {"lichen", "techno", "Elinor"}, ...}

5- But if you filter it base on if they have meaning in other 2 criteria, you will get None:

filterNonSenseWordsOrRepeatedLetters[{yellowWord_, blueWord_, 
   greenWord_}] := 
 Module[{orangeWord, purpleWord, 
   yl = ToLowerCase@Characters@yellowWord, bl = Characters@blueWord, 
   gl = ToLowerCase@Characters@greenWord},
  
  purpleWord = 
   StringJoin[bl[[1]], yl[[2]], yl[[3]], yl[[5]], gl[[5]], gl[[6]]];
  orangeWord = 
   StringJoin[bl[[1]], gl[[1]], gl[[2]], yl[[4]], yl[[5]], gl[[6]]];
  Return[DictionaryWordQ@purpleWord && DictionaryWordQ@orangeWord && 
    DuplicateFreeQ@Characters@purpleWord && 
    DuplicateFreeQ@Characters@orangeWord];
  ]

Select[result, filterNonSenseWordsOrRepeatedLetters]

(*Out: {} *)

Plot Results

This function will plot three words, but you can change it to show those other nonsense words:

drawWords[w1_, w2_, w3_] := Module[{},
  Graphics@{
    MapIndexed[Text[#1, {{3, 4, 5, 6, 7, 8}[[#2[[1]]]], 2}] &, Characters@w1],
    MapIndexed[Text[#1, {{1, 2, 5, 6, 8, 9}[[#2[[1]]]], 1}] &, Characters@w2],
    MapIndexed[Text[#1, {{2, 3, 4, 8, 9, 10}[[#2[[1]]]], 3}] &,Characters@w3]}]

Sample:

drawWords["amours", "arouse", "Ramsey"]

enter image description here

$\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.