Word Patterns for Cryptography

I want a function f that takes a word (like those listed in WordList[]) and returns a pattern best described by examples like these: f[“book”]=abbc; f[“settings”]=abccdefa; and f[“moving”]=abcdef.

Then I want a second function, f2, that searches a list of words for words that have the same pattern, returning a list of them; for example f2[WordList[],abcdefabgd]={liberalize, roisterous, stochastic}

The motive is to write a program that solves substitution ciphers, but could have other uses too!

• Can you explain what you are looking for? What is the logic behind "book" equalling abba? – bill s Feb 23 '17 at 20:03
• @bills probably book -> abbc ? – yarchik Feb 23 '17 at 20:09
• yes, sorry for the typo; book->abbc – donsiano Feb 23 '17 at 20:37

You can split the string and turn it into a pattern like this:

makePattern[word_String] := StringExpression @@ Map[
With[{s = Symbol @ #}, Pattern[s, Blank[]]] &,
Characters[word]];

findMatches[word_String, list_List : WordList[]] :=
Select[list, StringMatchQ[makePattern @ word]];


Which gives you

findMatches @ "settings"


{"diffused", "golliwog", "greening", "greeting", "grooming", "grooving", "guzzling", "littoral", "rollover", "succubus", "suppress", "syllabus"}

f1 = "" <> Alphabet[][[ArrayComponents @ Characters @ #]] &;

f2 = GroupBy[f1];


Use:

f1 /@ {"book", "settings", "moving"}

{"abbc", "abccdefa", "abcdef"}

allwords = DictionaryLookup[];

find = f2[allwords];  (* cache lookup table for all patterns *)

find["abcdefabgd"]

{"liberalize", "stochastic"}


(I don't have WordList in v10.1.0 so I substituted DictionaryLookup.)

Although it is much better to cache find as shown above this works without f2:

DictionaryLookup[x__ /; f1[x] === "abcdefabgd"]

{"liberalize", "stochastic"}


Performance

Although it should not matter if you only build find once as shown, ArrayComponents proves to be a bottleneck in my f1 code. Here is a more verbose equivalent that is an order of magnitude faster, should it matter.

f1fast =
With[{cc = ToCharacterCode @ #},
cc
// DeleteDuplicates
// AssociationThread[# -> Take[Alphabet[], Length@#]] &
// Lookup[cc]
// StringJoin
] &;


Here's a slightly more robust variation of mvonh's fine answer which uses Unique to ensure that the symbols used to mark patterns don't collide with variables that have values.

makePattern[word_String] :=
With[{chars = Characters@word},
Apply[
StringExpression,
chars /.
AssociationMap[With[{s = Unique@#}, Pattern[s, Blank[]]] &,
DeleteDuplicates@chars]]];


Define a function to code the words:

code[word_] := Module[{},
split = Characters[word];
numLetters = Length@Tally[split];
subs = Thread[Tally[split][[All, 1]] -> Range[numLetters]];
subs2 = Thread[Range[numLetters] -> CharacterRange["a", "z"][[1 ;; numLetters]]];
StringJoin[split /. subs /. subs2]]


So for example

code["abandonment"]
"abacdecfgch"


Then we can search the dictionary using Nearest with a custom distance function:

dist[w1_, w2_] := EditDistance[code[w1], code[w2]];

allWords = WordList[];
Nearest[allWords, "abandonment", 5, DistanceFunction -> dist]


Showing that these are the 5 nearest words to "abandonment" using the code notion of distance. Or, if you want only those that have exactly the same form,
Select[WordList[], code[#] == code["settings"] &]