Question about Replacements and String Manipulations

Question

I'm trying to get better at Mathematica and in the book I'm using (by Nancy Blachman) is the following question (which apparently was taken from another book: The Art and Science of C) which reads:

On a standard telephone keypad, the digits are mapped onto the alphabet (minus the letters Q and Z) as shown below:

        ABC     DEF
 1       2       3
GHI     JKL     MNO
 4       5       6
PRS     TUV     WXY
 7       8       9

Write a function phoneSpell that generates all possible letter combinations that correspond to a given number, represented as a string of digits. For example, if you call phoneSpell[652], your function should generate the 27 possible letter combinations corresponding to that prefix, namely

{"MJA", "MJB", "MJC", "MKA", "MKB", "MKC", "MLA", "MLB", "MLC", 
"NJA", "NJB", "NJC", "NKA", "NKB", "NKC", "NLA", "NLB", "NLC", "OJA",
"OJB", "OJC", "OKA", "OKB", "OKC", "OLA", "OLB", "OLC"}

Note that if the argument passed to phoneSpell contains a 0 or 1, that position in the output should simply be displayed as that digit, since there are no letters that correspond to it.

I've tried various things like first converting the number to a String using ToString and getting the Length using StringLength. I've tried a combination of Outer and Tuples to get the different combinations, but I'm not getting much luck. Any pointers in the right direction will be appreciated. Thanks.

Answer 1

Here is one approach that does what you want:

phoneSpell[n_Integer] := With[{k = StringLength@ToString@n, v = IntegerDigits@n, 
   r = {0 -> "0", 1 -> "1", 2 -> "ABC", 3 -> "DEF", 4 -> "GHI", 
     5 -> "JKL", 6 -> "MNO", 7 -> "PRS", 8 -> "TUV", 9 -> "WXY"}}, 
  StringJoin @@@ Flatten[Outer[List, Sequence @@ Characters[v /. r]], k - 1]]

Then:

phoneSpell[652]

{"MJA", "MJB", "MJC", "MKA", "MKB", "MKC", "MLA", "MLB", "MLC", "NJA", 
 "NJB", "NJC", "NKA", "NKB", "NKC", "NLA", "NLB", "NLC", "OJA", "OJB", 
 "OJC", "OKA", "OKB", "OKC", "OLA", "OLB", "OLC"}

phoneSpell[650231]

{"MJ0AD1", "MJ0AE1", "MJ0AF1", "MJ0BD1", "MJ0BE1", "MJ0BF1", 
"MJ0CD1", "MJ0CE1", "MJ0CF1", "MK0AD1", "MK0AE1", "MK0AF1", "MK0BD1", 
"MK0BE1", "MK0BF1", "MK0CD1", "MK0CE1", "MK0CF1", "ML0AD1", "ML0AE1", 
"ML0AF1", "ML0BD1", "ML0BE1", "ML0BF1", "ML0CD1", "ML0CE1", "ML0CF1", 
"NJ0AD1", "NJ0AE1", "NJ0AF1", "NJ0BD1", "NJ0BE1", "NJ0BF1", "NJ0CD1", 
"NJ0CE1", "NJ0CF1", "NK0AD1", "NK0AE1", "NK0AF1", "NK0BD1", "NK0BE1", 
"NK0BF1", "NK0CD1", "NK0CE1", "NK0CF1", "NL0AD1", "NL0AE1", "NL0AF1", 
"NL0BD1", "NL0BE1", "NL0BF1", "NL0CD1", "NL0CE1", "NL0CF1", "OJ0AD1", 
"OJ0AE1", "OJ0AF1", "OJ0BD1", "OJ0BE1", "OJ0BF1", "OJ0CD1", "OJ0CE1", 
"OJ0CF1", "OK0AD1", "OK0AE1", "OK0AF1", "OK0BD1", "OK0BE1", "OK0BF1", 
"OK0CD1", "OK0CE1", "OK0CF1", "OL0AD1", "OL0AE1", "OL0AF1", "OL0BD1", 
"OL0BE1", "OL0BF1", "OL0CD1", "OL0CE1", "OL0CF1"}

There's also this slight variation of the above solution:

phoneSpell2[n_Integer] := With[{k = Length@(v = Characters@ToString@n), 
   r = {"2" -> "ABC", "3" -> "DEF", "4" -> "GHI", "5" -> "JKL", 
     "6" -> "MNO", "7" -> "PRS", "8" -> "TUV", "9" -> "WXY"}}, 
  StringJoin @@@ Flatten[Outer[List, Sequence @@ Characters[v /. r]], k - 1]]

Answer 2

borrowing rules from RunnyKine

r = {0 -> "0", 1 -> "1", 2 -> "ABC", 3 -> "DEF", 4 -> "GHI", 
   5 -> "JKL", 6 -> "MNO", 7 -> "PRS", 8 -> "TUV", 9 -> "WXY"};


n = 652;
StringJoin @@@ Tuples[Characters /@ IntegerDigits@n /. r]


(*{"MJA", "MJB", "MJC", "MKA", "MKB", "MKC", "MLA", "MLB", "MLC", 
"NJA", "NJB", "NJC", "NKA", "NKB", "NKC", "NLA", "NLB", "NLC", "OJA", 
"OJB", "OJC", "OKA", "OKB", "OKC", "OLA", "OLB", "OLC"}*)

Answer 3

Slight modifications of existing answers of @RunnyKine and @Algohi (thanks guys!)

numRules = 
 MapThread[
  Rule, {Range[1, 9], {{"1"}}~
    Join~(Partition[CharacterRange["A", "Y"] // DeleteCases[#, "Q"] &,
       3])}]
(* {1 -> {"1"}, 2 -> {"A", "B", "C"}, 3 -> {"D", "E", "F"}, 
 4 -> {"G", "H", "I"}, 5 -> {"J", "K", "L"}, 6 -> {"M", "N", "O"}, 
 7 -> {"P", "R", "S"}, 8 -> {"T", "U", "V"}, 9 -> {"W", "X", "Y"}} *)



Clear[phoneSpell]
phoneSpell[n_Integer] := Module[{splitByZero, numToChar, joinedChar},
  splitByZero = 
   DeleteCases[SplitBy[IntegerDigits[n], (# == 0 &)], {0 ..}];
  FromDigits /@ splitByZero;
  numToChar = Tuples /@ (splitByZero /. numRules);
  joinedChar = {FromDigits /@ splitByZero, 
     Map[StringJoin, numToChar, {2}]} // Transpose
  ]

phoneSpell[6520123] // Grid[#, Frame -> All] &

---

Test to see if a dialed number matches any words in the dictionary

Clear[numDictQ]
numDictQ[n_Integer] := {phoneSpell[n][[All, 
    1]], (Select[#1, ! DictionaryLookup[ToLowerCase[#1]] == {} &] &) /@
     phoneSpell[n][[All, 2]]} // Transpose

numDictQ[78225039242643] // Grid[#, Frame -> All] &

---

Test to see if a string of letters, if dialed, will match any other strings of letters

Clear[abcToNum]
abcToNum[s_String] := 
  FromDigits@ToUpperCase@Characters[s] /. reverseNumRules;

numDictQ[abcToNum["phone spell"]] // Grid[#, Frame -> All] &