Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.)

share|improve this question
    
This is partly a code review question, since I already have an example which works fine enough for my application, yet I am wondering how much “better” I could have written it. As far as I could guess from this meta question, I hope it will be acceptable. –  F'x Mar 24 '12 at 16:44
5  
I think this is a great question and I will civilly resist any efforts to close or migrate it. –  Mr.Wizard Mar 24 '12 at 21:08
    
(I am leaving the above comments as I think this helps set guidelines in absence of a more fleshed out FAQ.) –  Mr.Wizard May 19 '12 at 23:13

7 Answers 7

up vote 19 down vote accepted

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.

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

altelem = Alternatives @@ elements;

f1[""] = Sequence[];

f1[s_String] :=
  Block[{f1},
    StringReplaceList[s, 
      StartOfString ~~ a : altelem ~~ b___ ~~ EndOfString :> {a, f1@b}
    ][[All, 1]] // Flatten]

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, here is a form that generates string lists:

f2[""] = "";

f2[s_String] := 
  Block[{f2}, StringReplaceList[s, 
    StartOfString ~~ a : altelem ~~ b___ ~~ EndOfString :> a ~~ f2@b
  ]] //. 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
share|improve this answer
3  
Really nice solution Mr.Wizard! @F'x: for the collapse, you can use the end of my answer: temp //. {{x_String, {y__String}} :> {x, y}} //. {x__String, y : {__List}} :> (Join[{x}, #] & /@ y), plugging Mr.Wizard's result into temp. –  István Zachar Mar 30 '12 at 13:53
1  
@F'x Another way of handling the tree would be: Replace[f1 @ "archbishop", {List[x_, y__] :> OpenerView[{x, y}], {p_} :> p}, {0, -1}] –  Sjoerd C. de Vries Mar 30 '12 at 19:05
    
Niiice one, clap clap –  Rojo Mar 31 '12 at 5:56
1  
@Mr.Wizard. I think your first answer is great now. The double replacement you wanted to avoid, can be avoided with a 40x speed increase in my tests, with your favourite trick: Block[{f1}, StringReplaceList[s, StartOfString ~~ a : altelem ~~ b___ ~~ EndOfString :> List[a, f1@b]][[All, 1]] // Flatten] –  Rojo Mar 31 '12 at 8:56
1  
The speedup is not because of the nested list replacement. You can use the same trick to speed up your second option, wrapping Block[{f2b}, ...] until right before the //. –  Rojo Mar 31 '12 at 9:37

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"]

share|improve this answer
    
Nice. Good explanation too. One thing: by splitting into all possible decompositions you needlessly increase the number of subsets. MMA will try combinations that never could form the word. like "b"and "bi", and "bi" and "i". –  Sjoerd C. de Vries Mar 30 '12 at 18:31
    
@SjoerdC.deVries The OP wanted all possible decompositions. I'm aware that the subsets grow large with increasing word length. Also, as the word gets longer, the chances of it being decomposable into chemical elements goes down drastically (I don't know the odds, but it's an empirical observation). –  rm -rf Mar 30 '12 at 19:20
    
Actually, I think I made an conceptual error here (end of the week etc.). Let's just forget it. –  Sjoerd C. de Vries Mar 30 '12 at 19:38
2  
@All: While the above is simple and intuitive, it is also wasteful. For example, in the case of "inconspicuousness", I generate about 3.5million subsets when I need only 24 of those. Even then, this generates 40 which contains duplicates due to the double s at the end (of course, a trivial fix with DeleteDuplicates). I'd appreciate pointers on improving this part of the code — either generating subsets in a smarter way or another approach to pair up. –  rm -rf Mar 31 '12 at 16:52

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.

share|improve this answer
    
Thanks István for this answer. I'm not sure it's using higher level constructs than my original code, and it sure is longer. But it's nice to see a different approach… –  F'x Mar 28 '12 at 13:59
    
@F'x, yes, yours is pretty much the simplest and most efficient so far I think. –  István Zachar Mar 28 '12 at 14:01

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.)

share|improve this answer
2  
As a former Fortran and C developer, I believe this solution doesn't remotely resemble what one would naturally code in either of those languages! The trick of using string operations to implement abstract data structures dates to a couple of mis-spent years developing in dBase. –  whuber Mar 30 '12 at 22:22
    
PS: If you like this reply, please vote up the one by Mr.Wizard: to satisfy the request by @F'x, I'm really just making a minor change to what he already accomplished. –  whuber Mar 30 '12 at 22:39
    
This is a nice addition, one I wish I had had time to make myself this morning. +1 –  Mr.Wizard Mar 30 '12 at 23:23

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]

(* 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})}] &,

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

recurse[ll_cons] :=
 Flatten[
  ReplaceList[ll, elementRules] /.
   {s_String, more_cons} :>
    With[{tails = recurse[more]},
     cons[s, #] & /@ tails]]
   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]= {}
share|improve this answer

Update #2

Now significantly cleaner and more efficient.

This uses an arbitrary maximum pattern length of 20. This should be sufficient for most words, but it could be raised at the loss of some performance.

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

altelem = ## | EndOfString & @@ elements;

pat = StartOfString ~~ ## -> {##}[[All, 1]] & @@ Table[Module[{x}, x : altelem], {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 practically fast:

words = DictionaryLookup["*"];

StringReplaceList[words, pat][[All, All, 1]] /. "" -> Sequence[]; // AbsoluteTiming
{1.3760787, Null}
share|improve this answer
1  
This is interesting. It successfully finds the different decompositions, but TraceXxx does not verbose about how it was achieved. I am flummoxed. –  István Zachar Mar 25 '12 at 0:03
    
Maybe it works like the Overlaps option: StringPosition["archbishop", altelem, Overlaps -> All]. –  FJRA Mar 25 '12 at 3:53
    
I’m awarding the bounty to this answer because, though both your answers are brilliant, I have a certain fondness for this one. –  F'x Apr 4 '12 at 16:14
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    "
share|improve this answer
    
Well, it’s not done yet, you they’re not ordered :) –  F'x Mar 30 '12 at 13:23
    
oh.. Is that important..? –  Lou Mar 30 '12 at 14:00
    
yeah, that's the crux of the problem… having a list of substrings is not the funniest part of the game :) –  F'x Mar 30 '12 at 14:06
    
@F'x And now? The words are back in their original order! –  Lou Mar 30 '12 at 15:06
    
@F'x I edited again. Forgot the last character in the word in the set function –  Lou Mar 30 '12 at 15:12

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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