Services & Resources / Wolfram Forums / MathGroup Archive

MathGroup Archive 2004

[Date Index] [Thread Index] [Author Index]

Search the Archive

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

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>
  • Prev by Date: Re: Re: Re: optimally picking one element from each list
  • Next by Date: Re: Re: Re: optimally picking one element from each list
  • Previous by thread: Re: Re: Re: optimally picking one element from each list
  • Next by thread: Re: Re: Re: optimally picking one element from each list