6
$\begingroup$

I'm a new guy here and I face a problem. I should pair the following words according to the rule: pair the words, that differ by max. 2 characters, like:

{chocolate, chocolates, thocolates} or {fox, nox, box}:

The list to apply this rule to is:

horse, horses, morse, morses, norse, norses, fox, monses, goose, tool, goal, tools, gothe

I had an idea with EditDistance, but I can compare the words with only using a sample (e.g. comparing fox with the other words), but it seemed not good...

Thanks your help!

One more thing: one word can appear not only once in the list, beceause one word can differ from more than one word...

Improve this question
$\endgroup$
3
  • $\begingroup$ Uh, one other thing, that on the list max 2 are being paired, like chocolates, thocolates or nox, box $\endgroup$
    – lewen
    Commented Nov 21, 2015 at 17:25
  • $\begingroup$ It seems we have 3 interpretations, could you say who has understood you well? $\endgroup$
    – Kuba
    Commented Nov 21, 2015 at 19:12
  • $\begingroup$ If you only need the pairs of such words you can directly Select them Select[Tuples[words, 2], EditDistance[#[[1]], #[[2]]] <= 2 &] $\endgroup$
    – mgamer
    Commented Nov 23, 2015 at 17:46

3 Answers 3

Reset to default
6
$\begingroup$ 
words = {"horse", "horses", "morse", "morses", "norse", "norses", 
  "fox", "monses", "goose", "tool", "goal", "tools", "gothe"}

I'm not very experienced with Graphs so any advice, how to make it shorter, is welcome.

adjacencyMatrix = Outer[
  Boole@LessEqual[1, #, 2] &@*EditDistance,
  words,
  words
];

adjacencyGraph = AdjacencyGraph[words, adjacencyMatrix];

Edit:

So we have 3 interpretations, let's deal with them all.

  1. Subsets of words where all elements are at most 2 EditDistance from each other:

    cliques = FindClique[ adjacencyGraph, Infinity, All ]

    {{"horse", "horses", "morse", "morses", "norse", "norses"}, 
{"horses", "morse", "morses", "norses", "monses"}, 
{"horse", "morse", "norse", "goose"},
{"goose", "gothe"}, 
{"tool", "tools"}, 
{"tool", "goal"}, 
{"fox"}}

  2. Pairs of words that differ at most 2 EditDistance from each other:

    List @@@ EdgeList@adjacencyGraph

    {{"horse", "horses"}, {"horse", "morse"}, {"horse", "morses"}, 
{"horse", "norse"}, {"horse", "norses"}, {"horse", "goose"}, 
{"horses", "morse"}, {"horses", "morses"}, {"horses", "norse"}, 
{"horses", "norses"}, {"horses", "monses"}, {"morse", "morses"},
{"morse", "norse"}, {"morse", "norses"}, {"morse", "monses"}, 
{"morse", "goose"}, {"morses", "norse"}, {"morses", "norses"},
{"morses", "monses"}, {"norse", "norses"}, {"norse", "goose"},
{"norses", "monses"}, {"goose", "gothe"}, {"tool", "goal"}, 
{"tool", "tools"}}

  3. Subsets of words where all elements differ from given word by at most 2 EditDistance:

    # -> VertexComponent[adjacencyGraph, #, 1] & /@ VertexList[adjacencyGraph]

{"horse" -> {"horse", "horses", "morse", "morses", "norse", "norses", 
   "goose"}, 
 "horses" -> {"horses", "horse", "morse", "morses", "norse", "norses",
    "monses"}, 
 "morse" -> {"morse", "horse", "horses", "morses", "norse", "norses", 
   "monses", "goose"}, 
 "morses" -> {"morses", "horse", "horses", "morse", "norse", "norses",
    "monses"}, 
 "norse" -> {"norse", "horse", "horses", "morse", "morses", "norses", 
   "goose"}, 
 "norses" -> {"norses", "horse", "horses", "morse", "morses", "norse",
    "monses"}, "fox" -> {"fox"}, 
 "monses" -> {"monses", "horses", "morse", "morses", "norses"}, 
 "goose" -> {"goose", "horse", "morse", "norse", "gothe"}, 
 "tool" -> {"tool", "goal", "tools"}, "goal" -> {"goal", "tool"}, 
 "tools" -> {"tools", "tool"}, "gothe" -> {"gothe", "goose"}}
Improve this answer
$\endgroup$
4
$\begingroup$ 
selector[str_String] :=
 GroupBy[list, EditDistance[str, #] <= 2 &][True] /.
  str -> Style[str, Red, Bold]

list = {"horse", "horses", "morse", "morses", "norse", "norses", 
   "fox", "monses", "goose", "tool", "goal", "tools", "gothe"};

selector /@ list

enter image description here

Alternatively,

selector2[str_String] :=
 Thread[str -> GroupBy[list, 0 < EditDistance[str, #] <= 2 &][True]]

Flatten[selector2 /@ list] /. Missing[__] :> {}

(*  {"horse" -> "horses", "horse" -> "morse", "horse" -> "morses", 
 "horse" -> "norse", "horse" -> "norses", "horse" -> "goose", 
 "horses" -> "horse", "horses" -> "morse", "horses" -> "morses", 
 "horses" -> "norse", "horses" -> "norses", "horses" -> "monses", 
 "morse" -> "horse", "morse" -> "horses", "morse" -> "morses", 
 "morse" -> "norse", "morse" -> "norses", "morse" -> "monses", 
 "morse" -> "goose", "morses" -> "horse", "morses" -> "horses", 
 "morses" -> "morse", "morses" -> "norse", "morses" -> "norses", 
 "morses" -> "monses", "norse" -> "horse", "norse" -> "horses", 
 "norse" -> "morse", "norse" -> "morses", "norse" -> "norses", 
 "norse" -> "goose", "norses" -> "horse", "norses" -> "horses", 
 "norses" -> "morse", "norses" -> "morses", "norses" -> "norse", 
 "norses" -> "monses", "fox" -> {}, "monses" -> "horses", "monses" -> "morse",
  "monses" -> "morses", "monses" -> "norses", "goose" -> "horse", 
 "goose" -> "morse", "goose" -> "norse", "goose" -> "gothe", "tool" -> "goal",
  "tool" -> "tools", "goal" -> "tool", "tools" -> "tool", "gothe" -> "goose"}  *)
Improve this answer
$\endgroup$
2
  • $\begingroup$ @Kuba - I am confused by the wording of the question; however, my approach groups all words within EditDistance of 2 from the base (Red) word. Each word is taken as the starting base. $\endgroup$
    – Bob Hanlon
    Commented Nov 21, 2015 at 18:48
  • $\begingroup$ My bad, I even changed the wording in my edit. I would think that @Kuba is right, because the originator also wondered about having to compare with one word only. $\endgroup$
    – gwr
    Commented Nov 21, 2015 at 19:13
2
$\begingroup$ 
list = 
  {"horse", "horses", "morse", "morses", "norse", "norses", 
     "fox", "monses", "goose", "tool", "goal", "tools", "gothe"};

char = Characters /@ Subsets[list, {2}];

rev = Reverse /@ (SortBy[#, Length] & /@ char);

com = Complement @@@ rev;

pos = Position[com, a_List /; Length@a <= 2]; 

Map[StringJoin, Extract[rev, pos], {2}] // Sort // TableForm

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ I'd say that fox and tool differ by 3 characters. p.s. you have a typo aster pos line. $\endgroup$
    – Kuba
    Commented Nov 23, 2015 at 8:27
  • $\begingroup$ Good point - I was thinking fox - o = fx = 2 chars difference. But with this logic all one and two letter words would qualify. $\endgroup$
    – eldo
    Commented Nov 23, 2015 at 11:41

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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