[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 |
\*------------------------------*/
Prev by Date:
**Re:Re: Set of strings reducing problem**
Next by Date:
**Complement replacement**
Previous by thread:
**Re: Set of strings reducing problem**
Next by thread:
**Re: Set of strings reducing problem**
| |