Splitting words into specific fragments

Question

I am looking into splitting words into a succession of chemical elements symbols, where possible. For example:

Titanic = Ti Ta Ni C (titanium, tantalum, nickel, carbon)

A word may or may not be decomposable under those rules, and if it is the decomposition might not be unique. I did two things: the first is a function checking if a decomposition is possible. I relied on the trivial regular expression to do so:

elements = ToLowerCase /@ 
  Select[Table[ElementData[i, "Symbol"], {i, Length@ElementData[]}], StringLength[#] < 3 &]
regexp = RegularExpression["(" <> StringJoin@Riffle[elements, "|"] <> ")+"];
decomposable[s_] := StringMatchQ[ToLowerCase@s, regexp];
decomposable /@ {"Mathematica", "archbishop"}

which gives: {False, True}.

Slightly harder was to implement a function returning possible decompositions. I recently learnt of the existence of Sow and Reap via this very website, so I implemented the most naïve, greedy algorithm with a recursive function:

beginsWith[s_, sub_] := (StringTake[s, Min[StringLength[s], StringLength[sub]]] == sub);
decompose0[s_, pre_] := Module[{list, remains},
   If[StringLength[s] == 0, Sow[pre]];
   list = Select[elements, beginsWith[s, #] &];
   remains = StringDrop[s, StringLength[#]] & /@ list;
   If[Length[list] >= 1, decompose0[remains[[1]], pre <> " " <> list[[1]]]];
   If[Length[list] >= 2, decompose0[remains[[2]], pre <> " " <> list[[2]]]];
 ];
decompose[s_] := Reap[decompose0[ToLowerCase@s, ""]][[2, 1]];

This works nicely:

In:= decompose["archbishop"]
Out= {" ar c h b i s h o p", " ar c h b i s ho p", " ar c h bi s h o p", " ar c h bi s ho p"}
In:= decompose["titanic"]
Out= {" ti ta n i c", " ti ta ni c"}

So, the question is: in which way could I use Mathematica’s higher-level functions, e.g. the pattern-matching ones, to improve the algorithm or the code simplicity? I'm not into code-golfing, so it's not about making the code shorter, but about using a better-optimized algorithm or writing higher-level code. (The above I could pretty much have written in C, C++ or Fortran, my usual languages.)

Answer 1

Here is a hybrid recursive/StringReplaceList method. It builds a tree representing all possible splits.

Now with a massive speed improvement thanks to Rojo's brilliance.

Updated element list per bobthechemist.

elements =
  Array[ElementData[#, "Symbol"] &, 118] /.
    {"Uup" -> "Mc", "Uus" -> "Ts", "Uuo" -> "Og"} //
    ToLowerCase;

f1[""] = Sequence[];

f1[s_String] := 
  Block[{f1}, 
    StringReplaceList[s, 
      StartOfString ~~ a : elements ~~ b___ ~~ EndOfString :> a ~~ f1@b
  ]]

Testing:

f1 @ "titanic"

{"ti" ~~ {"ta" ~~ {"n" ~~ {"i" ~~ {"c"}}, "ni" ~~ {"c"}}}}

f1 @ "archbishop"

{"ar" ~~ {"c" ~~ {"h" ~~ {"b" ~~ {"i" ~~ {"s" ~~ {"h" ~~ {"o" ~~ {"p"}}, 
     "ho" ~~ {"p"}}}}, "bi" ~~ {"s" ~~ {"h" ~~ {"o" ~~ {"p"}}, "ho" ~~ {"p"}}}}}}}

---

Responding to comments below and whuber's post, an extension that generates string lists:

f2[s_String] := { f1[s] } //. x_ ~~ y_ :> Thread[x ~~ "." ~~ y] // Flatten

f2 @ "titanic"

f2 @ "archbishop"

{"ti.ta.n.i.c", "ti.ta.ni.c"}

{"ar.c.h.b.i.s.h.o.p", "ar.c.h.b.i.s.ho.p", "ar.c.h.bi.s.h.o.p", "ar.c.h.bi.s.ho.p"}

---

Incidentally:

f2 @ "inconspicuousness"

in.c.o.n.s.p.i.c.u.o.u.s.n.es.s
in.c.o.n.s.p.i.c.u.o.u.s.ne.s.s
in.c.o.n.s.p.i.c.u.o.u.sn.es.s
in.c.o.n.s.p.i.cu.o.u.s.n.es.s
in.c.o.n.s.p.i.cu.o.u.s.ne.s.s
in.c.o.n.s.p.i.cu.o.u.sn.es.s
in.co.n.s.p.i.c.u.o.u.s.n.es.s
in.co.n.s.p.i.c.u.o.u.s.ne.s.s
in.co.n.s.p.i.c.u.o.u.sn.es.s
in.co.n.s.p.i.cu.o.u.s.n.es.s
in.co.n.s.p.i.cu.o.u.s.ne.s.s
in.co.n.s.p.i.cu.o.u.sn.es.s
i.n.c.o.n.s.p.i.c.u.o.u.s.n.es.s
i.n.c.o.n.s.p.i.c.u.o.u.s.ne.s.s
i.n.c.o.n.s.p.i.c.u.o.u.sn.es.s
i.n.c.o.n.s.p.i.cu.o.u.s.n.es.s
i.n.c.o.n.s.p.i.cu.o.u.s.ne.s.s
i.n.c.o.n.s.p.i.cu.o.u.sn.es.s
i.n.co.n.s.p.i.c.u.o.u.s.n.es.s
i.n.co.n.s.p.i.c.u.o.u.s.ne.s.s
i.n.co.n.s.p.i.c.u.o.u.sn.es.s
i.n.co.n.s.p.i.cu.o.u.s.n.es.s
i.n.co.n.s.p.i.cu.o.u.s.ne.s.s
i.n.co.n.s.p.i.cu.o.u.sn.es.s

Answer 2

Here is a fairly simple approach using only higher level functions. First, note that StringCases does almost all the work for you. István mentioned it in passing, but it is more powerful than that. It has an Overlap option that you can set to True to get all possible decompositions in one go:

elements = Table[ElementData[i, "Symbol"], {i, 112}];
StringCases["titanic", elements, Overlaps -> True, IgnoreCase -> True]
Out[1]= {"ti", "i", "ta", "n", "ni", "i", "c"}

StringCases["archbishop", elements, Overlaps -> True, IgnoreCase -> True]
Out[2]= {"ar", "c", "h", "b", "bi", "i", "s", "h", "ho", "o", "p"}

That's a pretty clean way of getting them all! I used IgnoreCase instead of ToLowerCase in elements, but either way is fine.

Next, you just need to find the subsets of the decomposition that give you back the original string. Since we're dealing with symbols of max length 2, your subsets only need to be restricted to $\displaystyle\lceil\frac{\text{string length}}{2}\rceil$ to $\text{string length}$:

Select[Subsets[{"ti", "i", "ta", "n", "ni", "i", "c"}, {4, 7}], StringJoin[#] == "titanic" &]
Out[3]= {{"ti", "ta", "ni", "c"}, {"ti", "ta", "n", "i", "c"}}

Select[Subsets[{"ar", "c", "h", "b", "bi", "i", "s", "h", "ho", "o", "p"}, {5, 10}], 
    StringJoin[#] == "archbishop" &]
Out[4]= {{"ar", "c", "h", "bi", "s", "ho", "p"}, 
         {"ar", "c", "h", "b", "i", "s", "ho", "p"}, 
         {"ar", "c", "h", "bi", "s", "h", "o", "p"}, 
         {"ar", "c", "h", "b", "i", "s", "h", "o", "p"}}

You can now bundle this up neatly as follows:

Begin["FXWords`"];
    elements = Table[ElementData[i, "Symbol"], {i, 112}];
    ElementDecompose[word_String] := Module[{decomps},
        decomps = StringCases[word, elements, Overlaps -> True, IgnoreCase -> True];
        Select[Subsets[decomps, {Ceiling[#/2], #}], StringJoin[#] == word &] &@StringLength[word]
    ];
End[];

and call it as FXWords`ElementDecompose["titanic"]

Answer 3

Some really simple partial answers using the string patternmatcher:

elements = ToLowerCase /@ 
  Select[Table[ElementData[i, "Symbol"], {i, Length@ElementData[]}], StringLength[#] < 3 &];

StringReplace["archbishop", # -> {#} & /@ elements] /. StringExpression -> Join
StringReplace["titanic", # -> {#} & /@ elements] /. StringExpression -> Join

{"ar", "c", "h", "b", "i", "s", "h", "o", "p"}

{"ti", "ta", "n", "i", "c"}

Even more simple is StringCases:

StringCases["archbishop", Alternatives @@ elements]

{"ar", "c", "h", "b", "i", "s", "h", "o", "p"}

And a more general solution for finding all decompositions:

updated to return correct decompositions

split[word_String] := Module[{list, findPath, temp},

   (* Generate an exhaustive list of positions of all possible elements in the input *)
   list = Sort@Flatten@DeleteCases[
       Table[i -> #, {i, StringPosition[word, #]}] & /@ elements, {}];

   (* recursive function to find all possible neighbouring elements in the string starting from position pos *)
   findPath[pos_, rest_] := If[pos == StringLength@word, 
     Last /@ Cases[rest, _?(First@First@# == pos &)], 
     Module[{newPos, newRest},
      newRest = Cases[rest, _?(First@First@# == pos &)];
      If[newRest === {}, {},
       {Last@#, findPath[newPos = Last@First@# + 1, 
           Cases[rest, _?(First@First@# >= newPos &)]]} & /@ newRest
       ]]];

   (* call the auxiliary function and tidy up results *)
   temp = findPath[1, list];
   If[temp === {}, {}, 
    temp //. {{x_} :> x, {} -> Sequence[], {x_String, {y__String}} :> {x, y}} //. 
        {x__String, y : {__List}} :> (Join[{x}, #] & /@ y)]
     ];

words = {"titanic", "silicon", "archbishop", "wombat"};
split /@ words // Column

{{"ti", "ta", "n", "i", "c"}, {"ti", "ta", "ni", "c"}}
{{{"s", "i", "li", "c", "o", "n"}, {"s", "i", "li", "co", "n"}}, {{"si", "li", "c", "o", "n"}, {"si", "li", "co", "n"}}}
{{{"ar", "c", "h", "b", "i", "s", "h", "o", "p"}, {"ar", "c", "h", "b", "i", "s", "ho", "p"}}, {{"ar", "c", "h", "bi", "s", "h", "o", "p"}, {"ar", "c", "h", "bi", "s", "ho", "p"}}}
{"w", "o"}

It now correctly gets all the valid decompositions, and returns partial decompositions for words that cannot be decomposed to elements.

Answer 4

You can implement list functionality with string operations, so it's straightforward to make the output of Mr.Wizard's elegant solution more readable while retaining the focus on string operations. Let's begin with a modified version of his solution (altelem is the same as before):

f1[""] = ",";
f1[s_String] := 
  StringJoin[
   StringReplaceList[s, 
    StartOfString ~~ a : altelem ~~ b___ ~~ EndOfString :> 
     assemble[a, f1@b]]];

Here's the crucial detail:

assemble[a_String, b_String] := StringReplace[b, "," ->  "," ~~ a ~~ "."];
decompose[s_String] := StringSplit[f1[s], ","]

assemble uses a comma to initiate and separate elements of a list of strings, which is represented as a single string. Its task is to prefix its first argument a to each element of its second argument b (thought of as a "list"). This is simply accomplished by StringReplace. (I have asked it to use "." in place of spaces to make it clear exactly what happens: this character serves as a lexeme terminator, not a separator.) decompose converts this string-qua-list representation back into a List.

E.g.,

decompose["titanic"]
{"ti.ta.n.i.c.", "ti.ta.ni.c."}

decompose["archbishop"]
{"ar.c.h.b.i.s.h.o.p.", "ar.c.h.b.i.s.ho.p.", "ar.c.h.bi.s.h.o.p.", "ar.c.h.bi.s.ho.p."}

decompose["breaking"]
{}

Of course, the input should not contain any commas. (If it does, change the comma in assemble and decompose to a character that does not appear.)

Answer 5

Here's a version that uses plain (not string) pattern matching and rule replacement, as well as recursion, to generate all decompositions.

EDIT to add: This approach turns out to be suprisingly efficient. I made no attempt to optimize my solution, and it doesn't make use of the string-handling functions at all, and it's about half as fast as Mr.Wizard's solution, at least on the word "inconspicuous". I've also updated the function to output the results not as lists, but as strings with "." separating the pieces, as with most other solutions.

I automatically generate the rules I need from the element symbols. I can't just use Characters to break up the string, because it's difficult to pattern match on List structures efficiently, and you can efficiently build linked lists recursively, so I convert everything into a linked list, and then extract my answers at the end:

(* Custom head for linked list nodes; it needs to be HoldAllComplete for 
   arcane performance reasons *)
Attributes[cons] = HoldAllComplete;

stringToLinkedList[s_String] := Fold[cons[#2, #1] &, cons[], Reverse@Characters@s];

linkedListToList[ll_cons] := List @@ Flatten[ll]

recurse[cons[]] := {cons[]};

recurse[ll_cons] :=
 Flatten[
  ReplaceList[ll, elementRules] /.
   {s_String, more_cons} :>
    With[{tails = recurse[more]},
     cons[s, #] & /@ tails]];

(* Now we can use the pattern matcher to efficiently match heads and tails 
   of the linked list, just like in a more conventional functional language
   like Haskell. *)
elementRules = Map[
   With[{chars = Characters@#},
     chars /. {
       {c_} :> (cons[c, more_cons] :> {c, more}),
       {c1_, c2_} :> (cons[c1, cons[c2, more_cons]] :> {#, more})}] &,


   elements];

decompose[s_String] := linkedListToList /@ recurse[stringToLinkedList@ToLowerCase@s] 

And now it works:

In[69]:= decompose["archbishop"]
Out[69]= {{"ar", "c", "h", "b", "i", "s", "h", "o", "p"}, 
          {"ar", "c", "h", "b", "i", "s", "ho", "p"},
          {"ar", "c", "h", "bi", "s", "h", "o", "p"}, 
          {"ar", "c", "h", "bi", "s", "ho", "p"}}   

In[70]:= decompose["Mathematica"]
Out[70]= {}

Answer 6

Update #2

Now significantly cleaner and more efficient.

This uses a maximum pattern length of 20 which should be sufficient for any English word.

elements = ToLowerCase @ Array[ElementData[#, "Symbol"] &, 112];

AppendTo[elements, EndOfString];

pat = StartOfString ~~ ## -> {##}[[All, 1]] & @@ Table[Module[{x}, x : elements], {20}];

StringReplaceList["archbishop", pat][[All, 1]] /. "" -> Sequence[]

{{"ar", "c", "h", "bi", "s", "ho", "p"},
 {"ar", "c", "h", "b", "i", "s", "ho", "p"},
 {"ar", "c", "h", "bi", "s", "h", "o", "p"},
 {"ar", "c", "h", "b", "i", "s", "h", "o", "p"}}

You can also process a list of words in one pass like this:

words = {"sarcophagus", "arboreal", "omnipotence", "nonrepresentational"}

StringReplaceList[words, pat][[All, All, 1]] /. "" -> Sequence[] // Column

{{s,ar,c,o,p,h,ag,u,s}, {s,ar,co,p,h,ag,u,s}}
{{ar,b,o,re,al}}
{{o,mn,i,p,o,te,n,ce}, {o,mn,i,po,te,n,ce}}
{{n,o,n,re,p,re,se,n,ta,ti,o,n,al}, {no,n,re,p,re,se,n,ta,ti,o,n,al}}

(quote marks omitted for space)

It is competitively fast:

words = DictionaryLookup[];

StringReplaceList[words, pat][[All, All, 1]] /. "" -> Sequence[]; // AbsoluteTiming

{1.3760787, Null}

Answer 7

elements = {"ac", "ag", "al", "am", "ar", "as", "at", "au", "b", "ba",
   "be", "bh", "bi", "bk", "br", "c", "ca", "cd", "ce", "cf", "cl", 
  "cm", "cn", "co", "cr", "cs", "cu", "db", "ds", "dy", "er", "es", 
  "eu", "f", "fe", "fm", "fr", "ga", "gd", "ge", "h", "he", "hf", 
  "hg", "ho", "hs", "i", "in", "ir", "k", "kr", "la", "li", "lr", 
  "lu", "md", "mg", "mn", "mo", "mt", "n", "na", "nb", "nd", "ne", 
  "ni", "no", "np", "o", "os", "p", "pa", "pb", "pd", "pm", "po", 
  "pr", "pt", "pu", "ra", "rb", "re", "rf", "rg", "rh", "rn", "ru", 
  "s", "sb", "sc", "se", "sg", "si", "sm", "sn", "sr", "ta", "tb", 
  "tc", "te", "th", "ti", "tl", "tm", "u", "v", "w", "xe", "y", "yb", 
  "zn", "zr"}



   set[x_] := Module[{str1, str2, i},
  i = 1;
  str1 = Characters[x];
  str2 = StringJoin[#] & /@ Partition[str1, 2, 1];
  Append[Flatten[{str1[[i++]], #} & /@ str2], str1[[-1]]]
  ]    

My InterSection:

    interSection[teststring_, dataset_] := 
 Module[{originalstring, intersect, tmp},
  originalstring = set[teststring];
  intersect = Intersection[originalstring, dataset];
  tmp = If[MemberQ[intersect, #], #, (## &[])] & /@ originalstring;
  StringJoin[StringJoin[(# <> " ") & /@ tmp], "   "]
  ]

Analyse sentence:

    sentenceToElements[sentence_, dataset_] := Module[{words},
  words = ReadList[StringToStream[sentence], Word];
  StringJoin[interSection[#, elements] & /@ words]
  ]

usage:

sentenceToElements["this is an example of the bischop showing of his \
    sumo wrestling skills", elements]

Output:

"th h i s    i s    n    am p    o f    th h he    b bi i s sc c h ho \
o p    s h ho o w i in n    o f    h i s    s u mo o    w re es s tl \
li i in n    s k i s    "

Answer 8

I think this answer provides an elegant solution -- at least for the less critical readers.

Note that the grammar generation code is the most complicated part. The rest is fairly direct and straightforward.

This generates an EBNF grammar for sequences of chemical elements:

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/FunctionalParsers.m"]

elemNames = 
  ToLowerCase[
   Sort[ElementData[#, "Abbreviation"] & /@ ElementData["*"]]];

ebnfChemElem = 
  "<chem-elem> = " <> 
   StringReplace[
    ToString[
     If[StringLength[#] == 1, "'" <> # <> "'", 
        StringJoin @@ 
         Riffle["'" <> # <> "'" & /@ Characters[#], ","]] & /@ 
      elemNames], {", " -> " | ", "{" -> "", "}" -> ""}] <> ";";

ebnfChemSplit = "<chem-split> = { <chem-elem> } ;";

ebnfChemElem <> "\n" <> ebnfChemSplit

The rule for the <chem-split> specifies that <chem-split> is a list of <chem-elem> strings.

The following code generates parsers and adds parser modifiers to concatenate the characters:

res = GenerateParsersFromEBNF[ ParseToEBNFTokens[ebnfChemElem <> ebnfChemSplit]];
LeafCount[res]

(* 4646 *)

SetParserModifier[pCHEMELEM, StringJoin[Flatten[{#}]] &];

SetParserModifier[pCHEMSPLIT, Map[StringJoin, #] &];

The following parsing examples are with the generated pCHEMSPLIT:

words = {"titanic", "silicon", "archbishop", "wombat", "mathematica"};
ParsingTestTable[pCHEMSPLIT, words, "TokenizerFunction" -> Characters]

The above does not parse all possible cases because ParseMany is implemented to pick shortest parsing paths. The parser generator uses ParseMany for { ... } parts in the EBNF rules.

With an alternative, greedier ParseMany implementation we can get all possible valid parsings:

pChemElem = 
  ParseModify[DeleteDuplicates, 
   ParseApply[Flatten,ParseManyByBranching[pCHEMELEM]]];

words = {"titanic", "silicon", "archbishop", "wombat", "mathematica"};
ParsingTestTable[pChemElem, words, "TokenizerFunction" -> Characters]

(Initially I did not think that posting this answer would contribute to the discussion, but then it occurred to me that it is a continuation of another discussion with Mr.Wizard over programming styles.)