Re: Re: Re: optimally picking one element from each list
- To: mathgroup at smc.vnet.net
- Subject: [mg48366] Re: [mg48324] Re: [mg48308] Re: [mg48297] optimally picking one element from each list
- From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Date: Tue, 25 May 2004 07:18:11 -0400 (EDT)
- References: <200405220704.DAA08848@smc.vnet.net> <200405231015.GAA21155@smc.vnet.net> <200405240445.AAA08868@smc.vnet.net> <E2802AB0-AD75-11D8-9FDB-000A95B4967A@mimuw.edu.pl> <opr8itwntoiz9bcq@holycow.cox-internet.com> <65B6A480-ADCA-11D8-996B-000A95B4967A@mimuw.edu.pl> <opr8i15xqmiz9bcq@holycow.cox-internet.com> Fred Simons <f.h.simons@tue.nl>, mathgroup <mathgroup@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Undobutedly Carl has once again showed the value of thinking before one
starts programming: his algorithm is cleary the way to solve such
problems.
So I now find myself in a position a salesman stuck with an obsolete
product and naturally I need a bit of skillful marketing. Well, the
backtracking algorithm is vastly slower in this situation than Carl's
approach, but maybe it has something to recommend it? I can think of
two things. First of all, it is very easy, essentially without any loss
of speed to adapt it to find all solutions rather than just one, for
after all it has to do that anyway. Of course Carl's method can also be
so adapted, but that will make it already somewhat slower. Secondly,
the approach is very flexible, one can for example replace Split by
Split[#,test] where test is any test. I am not sure if it is possible
to do that using Intersection[,SameTest ->test] and Carl's method; I
tried it briefly but could not make it work. Anyway, here is the more
general code:
<< DiscreteMath`Combinatorica`
BacktrackPick[sp_, tst_:SameQ] := Block[{n = Length[sp], c = Length[
sp], w, partialQ, solutionQ, sols},
partialQ[l_List] := Which[Length[l] == n && (w = Length[Split[l,
tst]]) <= c, c = w; True, Length[l] < n &&
Length[Split[l, tst]] <= c, True, True, False];
solutionQ[l_List] := If[Length[l] ==
n && (w = Length[Split[l, tst]]) <= c, c = w; True, False];
sols =
Backtrack[sp, partialQ,
solutionQ, All]; Select[sols,
Length[Split[#, tst]] == Length[Split[Last[sols], tst]] &]]
Suppose we take the list
sp = {{1,
5, 7}, {4, 5, 8, 9}, {3, 5, 6, 8}, {4, 7, 9, 10}, {
4, 7, 9, 10}, {0, 4, 10}, {2, 4, 8, 10}, {3, 5, 8}, {2, 5,
7, 8}, {1, 3, 7, 10}};
and suppose we want to solve Daniel's problems but we consider
sequences which jump by less than 1 (up or down). In other words, we
minimise Split[ ,Abs[#1-#2]<=1&].
Here is the complete solution:
In[50]:=
Timing[BacktrackPick[sp, Abs[#1 - #2] <= 1 & ]]
Out[50]=
{0.20000000000000284*Second,
{{5, 4, 3, 4, 4, 4, 4, 3, 2, 1}, {5, 4, 3, 4, 4, 4, 4,
3, 2, 3}, {5, 4, 5, 4, 4, 4, 4, 3, 2, 1},
{5, 4, 5, 4, 4, 4, 4, 3, 2, 3}, {5, 5, 5, 4, 4, 4, 4,
3, 2, 1}, {5, 5, 5, 4, 4, 4, 4, 3, 2, 3}}}
Andrzej Kozlowski
On 25 May 2004, at 08:28, DrBob wrote:
> Here are a couple of timings for the three methods (Carl Woll's, mine,
> and Andrzej Kozlowski's). My method probably uses too much memory for
> large problems, and Andrzej's uses too much time. Both could be
> optimized, but Carl's method would still beat them.
>
> test=Array[Union@Array[Random[Integer,10]&,4]&,10]
> Timing[pick@test]
> Timing[optimalSplit@test]
> Timing[BacktrackPick@test]
>
> {{1,5,7},{4,5,8,9},{3,5,6,8},{4,7,9,10},{4,7,9,10},{0,4,10},{2,4,8,10},
> {
> 3,5,8},{2,5,7,8},{1,3,7,10}}
>
> {0. Second,{4,{5,5,5,4,4,4,4,5,5,1}}}
>
> {0.063 Second,{4,{5,5,5,4,4,4,4,5,5,1}}}
>
> {1.531 Second,{4,{5,5,5,10,10,10,10,8,8,10}}}
>
> test=Array[Union@Array[Random[Integer,10]&,4]&,10]
> Timing[pick@test]
> Timing[optimalSplit@test]
> Timing[BacktrackPick@test]
>
> {{1,3,6,7},{2,6,10},{1,2,3},{1,6,10},{5,
> 9,10},{1,2,6},{6,8},{4,6,8},{2,3,5,8},{1,3,4,8}}
>
> {0. Second,{5,{6,6,1,1,5,6,6,6,3,3}}}
>
> {0.047 Second,{5,{6,6,1,1,5,6,6,6,3,3}}}
>
> {0.468 Second,{5,{7,2,2,10,10,6,8,8,8,8}}}
>
> Bobby
>
> On Tue, 25 May 2004 06:36:20 +0900, Andrzej Kozlowski
> <akoz at mimuw.edu.pl> wrote:
>
>> It seems that I somehow sent a "pre-release" version of my code
>> instead
>> fo the finished one. It should have been:
>>
>>
>> << "DiscreteMath`Combinatorica`"
>>
>>
>> BacktrackPick[sp_] := Block[{n = Length[sp], c = Length[sp], w,
>> partialQ, solutionQ},
>> partialQ[l_List] := Which[Length[l] == n && (w = Length[Split[l]])
>> <= c, c = w; True,
>> Length[l] < n && Length[Split[l]] <= c, True, True, False];
>> solutionQ[l_List] := If[Length[l] == n && (w = Length[Split[l]])
>> <=
>> c, c = w; True, False];
>> Last[Backtrack[sp, partialQ, solutionQ, All]]]
>>
>>
>> Andrzej
>>
>>
>>
>>
>>
>>
>> On 25 May 2004, at 05:30, DrBob wrote:
>>
>>> I got errors (see attached) before getting to any tests.
>>>
>>> Bobby
>>>
>>> On Mon, 24 May 2004 20:31:23 +0900, Andrzej Kozlowski
>>> <akoz at mimuw.edu.pl> wrote:
>>>
>>>> What errors do you get and on what examples? At least on the ones
>>>> you
>>>> gave below my function works fine. I have not yet found one where it
>>>> fails.
>>>>
>>>> As I wrote in the original posting, I am sure it can be made faster
>>>> if
>>>> someone wrote an optimised backtracking code rather than rely on
>>>> the
>>>> Backtrack function form the Combinatorica package. But I do not wish
>>>> to
>>>> spend time on this.
>>>>
>>>> Using compiled optimizers ought to be faster, maybe much faster on
>>>> the
>>>> whole, though perhaps not in all cases. Performance in this sort of
>>>> problem seems to depend very much on the starting configuration. For
>>>> example, if if the backtracking algorithm happens to find a "best"
>>>> solution early on it will finish much earlier than when it finds it
>>>> only near the end of the search.
>>>>
>>>>
>>>> Andrzej
>>>>
>>>> On 24 May 2004, at 13:45, DrBob wrote:
>>>>
>>>>> I get errors when I try Andrzej's function; maybe others had more
>>>>> luck?
>>>>>
>>>>> Here's a solution using Minimize. It may be wasteful in the setup,
>>>>> but
>>>>> solution will be very fast. I'm not certain a Sort isn't needed
>>>>> somewhere in the last statement, but this seems OK.
>>>>>
>>>>> An even faster method would solve a corresponding shortest path
>>>>> problem, if we have a solver available. I don't have to require or
>>>>> check for integer solutions below, because of that correspondence;
>>>>> basic optimal solutions will be integer automatically.
>>>>>
>>>>> Clear[choice, optimize]
>>>>> optimize[raw:{__List}] :=
>>>>> Module[{sets = Union /@ raw, choice, costBounds,
>>>>> choiceConstraints, pVar, costConstraints,
>>>>> objective, p, cVar, vars, bounds, solution},
>>>>> choice[set_, {index_}] :=
>>>>> Plus @@ (p[index, #1] & ) /@ set == 1;
>>>>> costBounds[{set1_, set2_}, {index_}] :=
>>>>> Module[{switches},
>>>>> switches = Plus @@ (p[index, #1] & ) /@
>>>>> Complement[set1, set2];
>>>>> {(cost[index] >= switches + (p[index, #1] -
>>>>> p[index + 1, #1]) & ) /@ Intersection[
>>>>> set1, set2], cost[index] >= switches}];
>>>>> choiceConstraints = Flatten[MapIndexed[choice,
>>>>> sets]]; pVar = Union[Cases[choiceConstraints,
>>>>> _p, Infinity]]; costConstraints =
>>>>> Flatten[MapIndexed[costBounds, Partition[sets, 2,
>>>>> 1]]]; cVar = Union[Cases[costConstraints,
>>>>> _cost, {2}]]; objective = Plus @@ cVar;
>>>>> vars = Flatten[{pVar, cVar}];
>>>>> bounds = Thread[0 <= vars <= 1];
>>>>> solution = Minimize[Flatten[{objective,
>>>>> choiceConstraints, costConstraints, bounds}],
>>>>> vars]; Cases[Last[solution] /. Rule -> rule,
>>>>> rule[p[_, a_], 1] :> a]]
>>>>>
>>>>> Timing@optimize@{{1,3},{2,3},{1,3},{1,3,4},{4,1}}
>>>>> Timing@optimize@{{6},{2},{2},{7,8},{3,4,1},{2,8,2},{5,2},{7},{8,5,8
>>>>> },
>>>>> {2
>>>>> ,1,
>>>>> 7},{5},{5}}
>>>>>
>>>>> {0.06299999999999999*Second, {3, 3, 3, 3, 1}}
>>>>> {0.015000000000000013*Second, {6, 2, 2, 7, 1, 2, 2, 7, 5, 1, 5,
>>>>> 5}}
>>>>>
>>>>> Bobby
>>>>>
>>>>> On Sun, 23 May 2004 06:15:35 -0400 (EDT), Andrzej Kozlowski
>>>>> <akoz at mimuw.edu.pl> wrote:
>>>>>
>>>>>>
>>>>>> On 22 May 2004, at 16:04, Daniel Reeves wrote:
>>>>>>
>>>>>>> Suppose you have a list of lists and you want to pick one element
>>>>>>> from
>>>>>>> each and put them in a new list so that the number of elements
>>>>>>> that
>>>>>>> are
>>>>>>> identical to their next neighbor is maximized.
>>>>>>> (in other words, for the resulting list l, minimize
>>>>>>> Length[Split[l]].)
>>>>>>> (in yet other words, we want the list with the fewest
>>>>>>> interruptions
>>>>>>> of
>>>>>>> identical contiguous elements.)
>>>>>>>
>>>>>>> EG, pick[{ {1,2,3}, {2,3}, {1}, {1,3,4}, {4,1} }]
>>>>>>> --> { 2, 2, 1, 1, 1 }
>>>>>>>
>>>>>>> Here's a preposterously brute force solution:
>>>>>>>
>>>>>>> pick[x_] := argMax[-Length[Split[#]]&, Distribute[x, List]]
>>>>>>>
>>>>>>> where argMax can be defined like so:
>>>>>>>
>>>>>>> (* argMax[f,domain] returns the element of domain for which f
>>>>>>> of
>>>>>>> that element is maximal -- breaks ties in favor of first
>>>>>>> occurrence.
>>>>>>> *)
>>>>>>> SetAttributes[argMax, HoldFirst];
>>>>>>> argMax[f_, dom_List] := Fold[If[f[#1] >= f[#2], #1, #2] &,
>>>>>>> First[dom], Rest[dom]]
>>>>>>>
>>>>>>> Below is an attempt at a search-based approach, which is also way
>>>>>>> too
>>>>>>> slow. So the gauntlet has been thrown down. Anyone want to give
>>>>>>> it
>>>>>>> a
>>>>>>> shot?
>>>>>>>
>>>>>>>
>>>>>>> (* Used by bestFirstSearch. *)
>>>>>>> treeSearch[states_List, goal_, successors_, combiner_] :=
>>>>>>> Which[states=={}, $Failed,
>>>>>>> goal[First[states]], First[states],
>>>>>>> True, treeSearch[
>>>>>>> combiner[successors[First[states]],
>>>>>>> Rest[states]],
>>>>>>> goal, successors, combiner]]
>>>>>>>
>>>>>>> (* Takes a start state, a function that tests whether a state is
>>>>>>> a
>>>>>>> goal
>>>>>>> state, a function that generates a list of successors for a
>>>>>>> state,
>>>>>>> and
>>>>>>> a function that gives the cost of a state. Finds a goal state
>>>>>>> that
>>>>>>> minimizes cost.
>>>>>>> *)
>>>>>>> bestFirstSearch[start_, goal_, successors_, costFn_] :=
>>>>>>> treeSearch[{start}, goal, successors,
>>>>>>> Sort[Join[#1,#2], costFn[#1] < costFn[#2] &]&]
>>>>>>>
>>>>>>> (* A goal state is one for which we've picked one element of
>>>>>>> every
>>>>>>> list
>>>>>>> in l.
>>>>>>> *)
>>>>>>> goal[l_][state_] := Length[state]==Length[l]
>>>>>>>
>>>>>>> (* If in state s we've picked one element from each list in l up
>>>>>>> to
>>>>>>> list
>>>>>>> i, then the successors are all the possible ways to extend s
>>>>>>> to
>>>>>>> pick
>>>>>>> elements thru list i+1.
>>>>>>> *)
>>>>>>> successors[l_][state_] := Append[state,#]& /@
>>>>>>> l[[Length[state]+1]]
>>>>>>>
>>>>>>> (* Cost function g: higher cost for more neighbors different
>>>>>>> (Length[Split[state]]) and then breaks ties in favor of longer
>>>>>>> states to keep from unnecessarily expanding the search tree.
>>>>>>> *)
>>>>>>> g[l_][state_] :=
>>>>>>> Length[Split[state]]*(Length[l]+1)+Length[l]-Length[state]
>>>>>>>
>>>>>>> (* Pick one element from each of the lists in l so as to minimize
>>>>>>> the
>>>>>>> cardinality of Split, ie, maximize the number of elements that
>>>>>>> are
>>>>>>> the same as their neighbor.
>>>>>>> *)
>>>>>>> pick[l_] := bestFirstSearch[{}, goal[l], successors[l], g[l]]
>>>>>>>
>>>>>>>
>>>>>>> --
>>>>>>> http://ai.eecs.umich.edu/people/dreeves - - google://"Daniel
>>>>>>> Reeves"
>>>>>>>
>>>>>>> If you must choose between two evils,
>>>>>>> pick the one you've never tried before.
>>>>>>>
>>>>>>>
>>>>>>>
>>>>>>
>>>>>> Here is an approach which, while not really fast, at least is much
>>>>>> faster than yours. It will correctly minimize Length[Split[l]],
>>>>>> but
>>>>>> will not necessarily give the same answer as your approach
>>>>>> because I
>>>>>> have not bothered to make sure that ties are settled in the way
>>>>>> you
>>>>>> indicated. It should not be hard to modify it to do so but I did
>>>>>> not
>>>>>> really wish to spend time on this matter.
>>>>>>
>>>>>> The idea is to use the Backtrack function from
>>>>>> DiscreteMath`Combinatorica`.
>>>>>>
>>>>>> Here is the program:
>>>>>>
>>>>>> <<DiscreteMath`Combinatorica`
>>>>>>
>>>>>> BacktrackPick[l_]:= Block[{n = Length[sp], c = Length[sp], w},
>>>>>> partialQ[l_List] := Which[Length[l] == n && (w =
>>>>>> Length[Split[
>>>>>> l]]) <= c, c = w; True, Length[l] < n &&
>>>>>> Length[Split[l]] <= c, True, True, False];
>>>>>> solutionQ[l_List] := If[Length[l] == n && (w =
>>>>>> Length[Split[l]])
>>>>>> <=
>>>>>> c,
>>>>>> c = w; True, False]; Last[Backtrack[sp, partialQ,
>>>>>> solutionQ,
>>>>>> All]]]
>>>>>>
>>>>>>
>>>>>> To see how this compares with yours let's create a random test
>>>>>> case:
>>>>>>
>>>>>>
>>>>>>
>>>>>> sp=Table[Table[Random[Integer,{1,9}],{Random[Integer,{1,3}]}],{12}
>>>>>> ]
>>>>>>
>>>>>>
>>>>>> {{6},{2},{2},{7,8},{3,4,1},{2,8,2},{5,2},{7},{8,5,8},{2,1,7},{5},{
>>>>>> 5}
>>>>>> }
>>>>>>
>>>>>> Let's try your pick function:
>>>>>>
>>>>>>
>>>>>> Length[Split[sol1=pick[sp]]]//Timing
>>>>>>
>>>>>>
>>>>>> {15.33 Second,9}
>>>>>>
>>>>>> Now BacktrackPick:
>>>>>>
>>>>>>
>>>>>> Length[Split[sol2=BacktrackPick[sp]]]//Timing
>>>>>>
>>>>>>
>>>>>> {0.34 Second,9}
>>>>>>
>>>>>> Quite a difference. This time the answers happened to be the same:
>>>>>>
>>>>>>
>>>>>> sol1
>>>>>>
>>>>>> {6,2,2,8,1,2,2,7,8,7,5,5}
>>>>>>
>>>>>> sol2
>>>>>>
>>>>>> {6,2,2,8,1,2,2,7,8,7,5,5}
>>>>>>
>>>>>> But this will not be the case in general.
>>>>>>
>>>>>> I am sure that one can write a customised backtracking solution
>>>>>> that
>>>>>> will be much faster than mine. However, writing customised (that
>>>>>> is
>>>>>> without using Backtrack) backtracking programs is a bit of an art
>>>>>> that
>>>>>> requires patience and care and I have a short supply of both of
>>>>>> these.
>>>>>> So I am cc-ing this message to a well known member of this list
>>>>>> who
>>>>>> is
>>>>>> a real master in this sort of thing ;-) so he might be interested
>>>>>> in
>>>>>> taking up the challenge.
>>>>>>
>>>>>> Andrzej Kozlowski
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>>
>>>>> --
>>>>> Using M2, Opera's revolutionary e-mail client:
>>>>> http://www.opera.com/m2/
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>>
>>> --
>>> Using M2, Opera's revolutionary e-mail client:
>>> http://www.opera.com/m2/<Andrzej.nb>
>>
>>
>
>
>
> --
> Using M2, Opera's revolutionary e-mail client: http://www.opera.com/m2/
>
>
- References:
- optimally picking one element from each list
- From: Daniel Reeves <dreeves@umich.edu>
- Re: optimally picking one element from each list
- From: Andrzej Kozlowski <akoz@mimuw.edu.pl>
- Re: Re: optimally picking one element from each list
- From: DrBob <drbob@bigfoot.com>
- optimally picking one element from each list