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

*To*: mathgroup at smc.vnet.net*Subject*: [mg48333] 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:16:48 -0400 (EDT)*References*: <200405220704.DAA08848@smc.vnet.net> <200405231015.GAA21155@smc.vnet.net> <200405240445.AAA08868@smc.vnet.net>*Sender*: owner-wri-mathgroup at wolfram.com

Oops, more testing shows that's not quite right! I'm working on a solution, using LinearProgramming. Bobby On Mon, 24 May 2004 00:45:20 -0400 (EDT), DrBob <drbob at bigfoot.com> 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/

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