Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2004
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2004

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

Search the Archive

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/


  • 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