Re: Re: Re: optimally picking one element from each list

*To*: mathgroup at smc.vnet.net*Subject*: [mg48359] Re: [mg48324] Re: [mg48308] Re: [mg48297] optimally picking one element from each list*From*: DrBob <drbob at bigfoot.com>*Date*: Tue, 25 May 2004 07:17:41 -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>*Sender*: owner-wri-mathgroup at wolfram.com

I've pushed the Send button too fast a few times, myself -- as you all know. 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>

**Re: Re: Re: optimally picking one element from each list**

**Re: Re: Re: optimally picking one element from each list**

**Re: Re: Re: optimally picking one element from each list**

**Re: Re: Re: optimally picking one element from each list**