Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Set of strings reducing problem

• To: mathgroup at smc.vnet.net
• Subject: [mg58591] Re: [mg58560] Set of strings reducing problem
• From: stephen layland <layland at wolfram.com>
• Date: Sat, 9 Jul 2005 04:07:51 -0400 (EDT)
• References: <200507070935.FAA29410@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

and thus spake Edson Ferreira [2005.07.07 @ 05:21]:
> 
> Dear Mathematica Users,
> 
> I have a problem that I haven't got any clue to solve with Mathematica.
> 
> Let's say a have a list of "n" equal length strings:

[ ... ]

here's an implementation of your approach.  it's quite wordy, but i 
think it should work.

first set up your string transformation rules, i'm using a throwaway
symbol s[] to attach the rules to:

s /: Plus[s["1"], s["X"]] = "D";
s /: Plus[s["1"], s["2"]] = "M";
s /: Plus[s["1"], s["U"]] = "T";
s /: Plus[s["X"], s["2"]] = "U";
s /: Plus[s["X"], s["M"]] = "T";
s /: Plus[s["2"], s["D"]] = "T";
s /: Plus[s[s1_String], s[s2_String]] := s1

the last rule is something i threw in to handle string combinations you
didn't supply.  you'll probably want to handle these differently.

next, i wrote some helper functions:

(* this is just UnsortedUnion from the help browser, see Union[] *)
uniq[x_]:= Module[{f}, f[y_] := (f[y] = Sequence[]; y); f /@ x]

(* this applies the string transformations iff the two lists differ
   in exactly one position *)
stringReduce[l1_List, l2_List] := Module[
 {t = Equal @@@ Transpose[{l1, l2}], p},
  If[Count[t, False] == 1,
   p = Position[t, False][[1, 1]];
   ReplacePart[l1, Plus @@ (s /@ {l1[[p]], l2[[p]]}), p],
   Sequence @@ {l1, l2}
   ]
  ]


now, the trivial function that will actually do an iteration 
of the list:

listReduce[l_List] := uniq[stringReduce@@@Tuples[l,2]]
(* tuples is new in 5.1. if you don't have 5.1, you can use this:
       Flatten[Outer[List, l, l, 1],1]
   to achieve the same thing (those are two ell's and a one) *)


finally, we can use FixedPoint to reduce the list until it can be
reduced no more.  I created a simple list of sample strings to test:

alphabet = {"1", "X", "2", "U", "M", "D", "T"};
l = Flatten[{
  {"1", "1", "1", "1", #, "1", "1", "1"}, 
  {"2", "1", "1", "1", #, "1", "1", "2"}} & /@ alphabet, 1];


FixedPoint[listReduce,l]//ColumnForm


{"1", "1", "1", "1", "1", "1", "1", "1"}
{"2", "1", "1", "1", "1", "1", "1", "2"}
{"2", "1", "1", "1", "X", "1", "1", "2"}
{"2", "1", "1", "1", "2", "1", "1", "2"}
{"2", "1", "1", "1", "U", "1", "1", "2"}
{"2", "1", "1", "1", "M", "1", "1", "2"}
{"2", "1", "1", "1", "D", "1", "1", "2"}
{"2", "1", "1", "1", "T", "1", "1", "2"}
{"1", "1", "1", "1", "D", "1", "1", "1"}
{"1", "1", "1", "1", "M", "1", "1", "1"}
{"1", "1", "1", "1", "T", "1", "1", "1"}
{"1", "1", "1", "1", "X", "1", "1", "1"}
{"1", "1", "1", "1", "2", "1", "1", "1"}
{"1", "1", "1", "1", "U", "1", "1", "1"}

In this simple case, only one pass is necessary.
If you want to process the strings as they are in "221111X11"
form, you can simply slap in a call to Characters[] and StringJoin[].

--
/*------------------------------*\
|        stephen layland         |
|    Documentation Programmer    |
| http://members.wri.com/layland |
\*------------------------------*/

• References:
  • Set of strings reducing problem
    • From: "Edson Ferreira" <edsferr@uol.com.br>