Services & ResourcesWolfram ForumsMathGroup Archive

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

Re: optimally picking one element from each list

• To: mathgroup at smc.vnet.net
• Subject: [mg48308] Re: [mg48297] optimally picking one element from each list
• From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
• Date: Sun, 23 May 2004 06:15:35 -0400 (EDT)
• References: <200405220704.DAA08848@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

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

• Follow-Ups:
  • Re: Re: optimally picking one element from each list
    • From: DrBob <drbob@bigfoot.com>

• References:
  • optimally picking one element from each list
    • From: Daniel Reeves <dreeves@umich.edu>