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

*To*: mathgroup at smc.vnet.net*Subject*: [mg48358] 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:17:36 -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>*Sender*: owner-wri-mathgroup at wolfram.com

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>

**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**