Re: Set of strings reducing problem (Again!)
- To: mathgroup at smc.vnet.net
- Subject: [mg60599] Re: Set of strings reducing problem (Again!)
- From: "dkr" <dkrjeg at adelphia.net>
- Date: Wed, 21 Sep 2005 03:20:42 -0400 (EDT)
- References: <dgbf2b$fp6$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Edson,
Here is an alternate pattern matching approach.
Instead of decomposing strings via Characters and using the standard \
pattern matching techniques as you have done, it takes the opposite
tact, \
combining your original set of strings into a single string and then
applying \
the string matching techniques introduced in Version 5 of Mathematica
In[1]:=
origList={"111","11X","112","1X1","1XX","1X2","121","12X","122"};
In[2]:=
(* Here we form one long string from the strings in origList,
inserting list braces to delimit the individual strings *)
str= ToString[{#}]&/@origList//StringJoin
Out[2]=
{111}{11X}{112}{1X1}{1XX}{1X2}{121}{12X}{122}
In[3]:= %2//InputForm
Out[3]//InputForm=
"{111}{11X}{112}{1X1}{1XX}{1X2}{121}{12X}{122}"
In[4]:=
rr={{"1","X"},{"1","2"},{"1","U"},{"2","X"},{"M","X"},{"2","D"}};
rules=Thread[Rule[rr,{"D","M","T","U","T","T"}]]
Out[5]=
{{1,X}->D,{1,2}->M,{1,U}->T,{2,X}->U,{M,X}->T,{2,D}->T}
In[6]:=
Attributes[ss]=Orderless;
ss[i_String,j_String]/;MemberQ[rr,{i,j}]:=ss[i,j]={i,j};
(* ss[string1,string2] evaluates to a list only if there is a rule
available for the \
pair of strings *)
In[8]:=
fun[i_String]:=
StringReplace[i,
StringExpression["{",a:(WordCharacter)...,p:(WordCharacter),
c:(WordCharacter)...,"}",z___,"{",a___,q:(WordCharacter),c___,
"}"]/;MatchQ[ss[p,q],_List]:>"{"<>a<>(ss[p,q]/.rules)<>c<>"}"<>z];
In[9]:=fun[str]//InputForm
Out[9]//InputForm=
"{11M}{11X}{1XM}{1XX}{12M}{12X}"
(* Note that multiple replacements can occur during one iteration of \
StringReplace. Here 3 pairs of appropriately mismatched strings were
found.
In your approach, at most one pair of appropriately mismatched strings
is found during each \
iteration of ReplaceRepeated. *)
In[10]:=
(* We iterate using FixedPoint *)
FixedPoint[fun,str]//InputForm
Out[10]//InputForm=
"{1TT}"
In[11]:=
(* Finally we convert the result above, which is just a string,
back to a list of individual strings *)
StringCases[%,"{"~~a:(WordCharacter)..~~"}":>a]//FullForm
Out[11]//FullForm=
List["1TT"]
In[12]:=
(* FixedPointList exposes how much reduction is going on during each \
iteration of StringReplace *)
FixedPointList[fun,str]//FullForm
Out[12]//FullForm=
List["{111}{11X}{112}{1X1}{1XX}{1X2}{121}{12X}{122}","{11M}{11X}{1XM}{1XX}{\
12M}{12X}","{11T}{1XT}{12T}","{1MT}{1XT}","{1TT}","{1TT}"]
In[13]:=
(* We might do better forcing the rule in StringReplace to find the
shortest \
pattern match, using ShortestMatch *)
altfun[i_String]:=
StringReplace[i,
ShortestMatch[
StringExpression["{",a:(WordCharacter)...,p:(WordCharacter),
c:(WordCharacter)...,"}",z___,"{",a___,q:(WordCharacter),c___,
"}"]/;MatchQ[ss[p,q],_List]]:>
"{"<>a<>(ss[p,q]/.rules)<>c<>"}"<>z];
In[14]:=
FixedPointList[altfun,str]//FullForm
Out[14]//FullForm=
List["{111}{11X}{112}{1X1}{1XX}{1X2}{121}{12X}{122}","{1D1}{11X}{112}{1UX}{\
1X2}{121}{122}","{1T1}{11X}{112}{1UX}{1X2}{122}","{1T1}{1TX}{112}{1U2}","{1TD}\
{1T2}","{1TT}","{1TT}"]
(* Note we get a different sequence of reductions *)
In[15]:=
(* Summarizing all of the above *)
CleanSlate[];
In[1]:=
rr={{"1","X"},{"1","2"},{"1","U"},{"2","X"},{"M","X"},{"2","D"}};
rules=Thread[Rule[rr,{"D","M","T","U","T","T"}]];
Options[reductionFn]={shortmatch->False};
reductionFn[origList:{__String},opts___Rule]:=Module[{zmatch,ss,str,fp},
Attributes[ss]=Orderless;
ss[i_String,j_String]/;MemberQ[rr,{i,j}]:=ss[i,j]={i,j};
str=ToString[{#}]&/@origList//StringJoin;
zmatch=shortmatch/.{opts}/.Options[reductionFn];
fp:=FixedPoint[
StringReplace[#,
StringExpression["{",a:(WordCharacter)...,p:(WordCharacter),
c:(WordCharacter)...,"}",z___,"{",a___,
q:(WordCharacter),c___,"}"]/;
MatchQ[ss[p,q],_List]:>
"{"<>a<>(ss[p,q]/.rules)<>c<>"}"<>z]&,str]/;zmatch===False;
fp:=FixedPoint[
StringReplace[#,
ShortestMatch[
StringExpression["{",a:(WordCharacter)...,p:(WordCharacter),
c:(WordCharacter)...,"}",z___,"{",a___,
q:(WordCharacter),c___,"}"]/;
MatchQ[ss[p,q],_List]]:>
"{"<>a<>(ss[p,q]/.rules)<>c<>"}"<>z]&,str];
StringCases[fp,"{"~~a:(WordCharacter)..~~"}":>a]
];
In[7]:=
sampleList1={"111","11X","112","1X1","1XX","1X2","121","12X","122"};
reductionFn[sampleList1]//InputForm
Out[8]//InputForm=
{"1TT"}
In[9]:=
reductionFn[sampleList1,shortmatch->True]//InputForm
Out[9]//InputForm=
{"1TT"}
In[10]:=
sampleList2={"1111","111X","1121","112X","11X1","11XX","1211","121X","1221",
"12X1","1X11","1X1X","1X21","1XX1","2111","211X","2121","21X1","2211",
"2X11","X111","X11X","X121","X1X1","X211","XX11"};
reductionFn[sampleList2]//InputForm
Out[11]//InputForm=
{"11TD", "1U1D", "1UU1", "U11D", "U1U1", "UU11"}
(* The above is the solution your pattern matching approach yields *)
In[12]:=
reductionFn[sampleList2,shortmatch->True]//InputForm
Out[12]//InputForm=
{"T11D", "1TU1", "11UX", "TU11", "1U1X", "U1U1"}
(* Using the shortest match instead, we obtain the solution in my
previous message *)
I have no idea how efficient my pattern matching approach is relative
to your pattern matching approach. I would venture to guess that both
pattern matching approaches will be very inefficient relative to a
functional approach based on some of the ideas in the previous thread.
The problem with a pattern matching approach for your problem is that
the pattern is just too cumbersome.