Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2002
*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 2002

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

Search the Archive

RE: Need a algorithm

  • To: mathgroup at smc.vnet.net
  • Subject: [mg33894] RE: [mg33857] Need a algorithm
  • From: "DrBob" <majort at cox-internet.com>
  • Date: Sun, 21 Apr 2002 06:14:36 -0400 (EDT)
  • Reply-to: <drbob at bigfoot.com>
  • Sender: owner-wri-mathgroup at wolfram.com

Here's code that finds a good (but perhaps not optimal) solution (again,
if I've understood the problem statement).  It's a "greedy" algorithm
that selects tickets in turn.  It looks at all possible lottery draws
and selects one with minimal match with tickets already bought; that
draw is the next ticket bought.

 

q={8,11,13,14,16,22,23,28,31,32,34,35};

s=KSubsets[q,7];

minMatch:=Module[{t,m},

    t=Outer[Intersection,s,tickets,1];

    m=Min[Max[Length/@#]&/@t]

    ]

maxMatch[s_List]:=Max[Length/@(#\[Intersection]s&/@tick)]

buyNext:=Module[{t},

    t=maxMatch/@s;

    Flatten[s[[First[Position[t,Min[t]]]]]]

    ]

k=5;

tickets={Take[q,7]}

While[minMatch<k,

    AppendTo[tickets,buyNext]

    ];

tickets

 

For k=2, the result is {{8,11,13,14,16,22,23}}.

For k=3 and 4, the result is
{{8,11,13,14,16,22,23},{8,11,28,31,32,34,35}}

For k=5, the result is 10 tickets:

{{8,11,13,14,16,22,23},{8,11,28,31,32,34,35},{8,13,14,16,28,31,32},

{8,13,14,22,28,34,35},{8,13,16,23,31,34,35},{8,14,22,23,31,32,34},

{8,16,22,23,28,32,35},{11,13,14,16,32,34,35},{11,13,14,23,28,31,34},

{11,13,16,22,28,31,35}}

For k=6, the result is 63 tickets.

 

On my 2.2 GHz Pentium 4, this code took 28 seconds for k=6, but less
than one second for k=5.

 

A much more efficient code is:

 

ClearAll[maxMatch,minMatch,buyNext]

maxMatch[s_List]:=maxMatch[s]=Max[Length/@(#\[Intersection]s&/@tickets)]

buyNext:=Module[{nxt},

    nxt=Flatten[s[[First[Position[t,Min[t]]]]]];

    t=MapIndexed[Max[#1,Length[First[s[[#2]]]\[Intersection]nxt]]&,t];

    minMatch=Min[t];

    AppendTo[tickets,nxt]

    ]

 

tickets={};

minMatch=0;

s=KSubsets[q,7];

t=0&/@s;

k=6;

Timing[

  While[minMatch<k,

      buyNext

      ];

  ]

tickets//Dimensions

 

This code solved for k=6 in 1 second and k=7 in 13 seconds.  It prevails
because unnecessary Outer products are eliminated, and intersections of
subsets of q with tickets already bought are eliminated.

 

Bobby Treat


  • Prev by Date: RE: How Do You Reduce Multiple Elements in a List?
  • Next by Date: RE: Need a algorithm
  • Previous by thread: Need a algorithm
  • Next by thread: RE: Need a algorithm