Wolfram Language

Open live version

Make Mnemonics for Telephone Numbers

Make telephone numbers easy to remember by finding corresponding words or phrases.


code

TelephonePhrases[n_Integer] := With[{digits = IntegerDigits[n]}, StringJoin[Riffle[#, "-"]] & /@ Flatten[Tuples /@ TelephoneWordLists[digits], 1] ]
TelephoneWordLists[l_List] := Join[ {{TelephoneWords[l]}}, Flatten[Table[ With[{words = TelephoneWords[Take[l, i]]}, If[words === {}, {}, Join[{words}, #] & /@ TelephoneWordLists[Drop[l, i]] ]], {i, Length[l] - 1, 1, -1}], 1] ]
TelephoneWords[{0}] := {"0"}; TelephoneWords[{1}] := {"1"}; TelephoneWords[digits_List] := DictionaryLookup[RegularExpression[StringJoin[ {"[", ToLowerCase[#], ToUpperCase[#], "]"} & /@ ToLowerCase[DigitLetters /@ digits]]]]
DigitLetters = <|1 -> "1", 2 -> "ABC", 3 -> "DEF", 4 -> "GHI", 5 -> "JKL", 6 -> "MNO", 7 -> "PQRS", 8 -> "TUV", 9 -> "XYZ", 0 -> "0"|>;

how it works

This approach to finding words or phrases that correspond to telephone numbers takes three steps. First make a function that finds single words that correspond to a sequence of digits on a telephone pad. Then make a function that partitions a telephone number into all possible sequences and find words for each sub-sequence. Finally, make a function that forms all combinations of all words for all partitions.

Map digits to the corresponding letters on a telephone pad with a key-value Association. Since 0 and 1 have no letters, associate those digits with themselves:

DigitLetters = <|1 -> "1", 2 -> "ABC", 3 -> "DEF", 4 -> "GHI", 5 -> "JKL", 6 -> "MNO", 7 -> "PQRS", 8 -> "TUV", 9 -> "XYZ", 0 -> "0"|>

You can use the Association like a function to map a digit to the corresponding letters:

DigitLetters[2]

Map a sequence of digits to the corresponding letters by mapping the Association across the digit list:

letters = DigitLetters /@ {6, 3, 2, 8}

To find words that can be formed from those letter choices, construct a regular expression that specifies a sequence of letters, one from each group. Since the dictionary contains both lowercase and uppercase words, make the regular expression contain both lowercase and uppercase letters:

regexp = RegularExpression[StringJoin[ {"[", ToLowerCase[#], ToUpperCase[#], "]"} & /@ ToLowerCase[letters]]] ; regexp // InputForm

Use DictionaryLookup to find words that match the regular expression:

DictionaryLookup[regexp]

Package those steps as a function. Since the words 0 and 1 are not in the dictionary, add special-case rules for those digits:

TelephoneWords[{0}] := {"0"}; TelephoneWords[{1}] := {"1"}; TelephoneWords[digits_] := DictionaryLookup[RegularExpression[StringJoin[ {"[", ToLowerCase[#], ToUpperCase[#], "]"} & /@ ToLowerCase[DigitLetters /@ digits]]]]

Test the function:

TelephoneWords[{6, 3, 2, 8}]

The number 4686328 has no telephone word:

TelephoneWords[{4, 6, 8, 6, 3, 2, 8}]

But it can be broken into smaller sequences that do have words, for example:

TelephoneWords /@ {{4, 6, 8}, {6, 3, 2, 8}}
TelephoneWords /@ {{4, 6, 8, 6}, {3, 2, 8}}

Find all telephone phrases for a list of digits by finding every way of breaking a list of digits into smaller lists and finding words for each smaller list.

Start with a function that finds all partitions of a list into smaller lists. The function is most naturally formulated recursively by thinking about it this way: the partitions of a list are the list itself plus the first n elements of the list combined with all partitions of the remainder of the list, for every n from one less than the length of the list to one:

ListPartition[l_List] := Join[ {{l}}, Flatten[ Table[Join[{Take[l, i]}, #] & /@ ListPartition[Drop[l, i]], {i, Length[l] - 1, 1, -1}], 1] ]

An n-element list has 2n-1 partitions:

ListPartition[{1, 2, 3, 4}] // Column

With ListPartition, you can find all telephone word phrases by mapping TelephoneWords across the elements of each partition:

((TelephoneWords /@ #) & /@ ListPartition[{6, 3, 2, 8}]) // Column

For longer digit lists, however, this approach is prohibitively inefficient. It wastes too much time looking up words later in the list when it already knows that an earlier sublist has no words.

A better approach is to build the TelephoneWords call directly into the recursive function and abort as soon as you know that some sublist has no words. That is what TelephoneWordLists does:

TelephoneWordLists[l_List] := Join[ {{TelephoneWords[l]}}, Flatten[Table[ With[{words = TelephoneWords[Take[l, i]]}, If[words === {}, {}, Join[{words}, #] & /@ TelephoneWordLists[Drop[l, i]] ]], {i, Length[l] - 1, 1, -1}], 1] ]

TelephoneWordLists returns lists of lists of words:

TelephoneWordLists[{6, 3, 2, 6}] // Column

To make phrases from the lists of word alternatives, form all combinations of alternative words, for example:

tuples = Tuples[{{"me", "of"}, {"am", "AM", "an"}}]

Put hyphens between each word in a sequence using Riffle, and join all the components together into single strings with StringJoin:

StringJoin[Riffle[#, "-"]] & /@ tuples // Column

Package those steps into a function whose argument is an integer telephone number:

TelephonePhrases[n_Integer] := With[{digits = IntegerDigits[n]}, StringJoin[Riffle[#, "-"]] & /@ Flatten[Tuples /@ TelephoneWordLists[digits], 1] ]

Test the function on a number:

TelephonePhrases[4686328] // Column