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: RE: Need a algorithm

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

I suspected this algorithm would not always give optimal answers, and I
was right.  It occurred to me that choosing the First draw with minimal
(worst) match with already bought tickets would prejudice the algorithm
in an unfortunate direction, so I replaced First with a random draw.

(Note that \[Intersection] represents the intersection symbol.  Just
copy the text into a notebook.)

ClearAll[minMatch,buyNext,pickOne]
pickOne[a_List]:=a[[Random[Integer,{1,Length[a]}]]];
buyNext:=Module[{nxt},
    nxt=Flatten[s[[pickOne[Position[t,Min[t]]]]]];
    t=MapIndexed[Max[#1,Length[s[[First[#2]]]\[Intersection]nxt]]&,t];
    minMatch=Min[t];
    AppendTo[tickets,nxt]
    ]
s=KSubsets[q,7];

pickTickets[k_]:=(
    tickets={};
    minMatch=0;
    t=0&/@s;
    While[minMatch<k,buyNext];
    tickets//Length
    )

This code doesn't always give the same answer because of the randomness
involved.  Better answers than before were achieved on just about every
trial, and it runs faster as well (because it stops earlier).

In ten trials for k=5 to k=6, I had the following results (numbers of
tickets):

{{10,10,10,9,8,10,10,9,9,10},{57,53,57,58,59,60,59,57,55,62}}

Thus 8 tickets are enough for k=5 and 53 for k=6, compared to the
earlier answers of 10 and 63.  More trials might find even better
answers, so I ran it 100 times and chose the smallest number of tickets
found:

In[156]:=
Timing[
  Min/@Table[pickTickets[n],{n,5,6},{i,1,100}]
  ]

Out[156]=
{104.063 Second,{7,53}}

7 tickets suffice for k=5, and 53 tickets for k=6.  But 500 iterations
gave an even better answer for k=6:

In[157]:=
Timing[
  Min/@Table[pickTickets[n],{n,5,6},{i,1,500}]
  ]
Out[157]=
{514.578 Second,{7,52}}

Unfortunately, another trial of 500 iterations gave the answers 8 and
52.

If this many iterations are required to get an answer that may still be
larger than optimal, exhaustive search may be indicated instead of the
heuristic search I've used.  However, there are MANY possibilities when
looking at 6 tickets, for instance.

This is probably a straight-forward problem in coding theory, by the
way.

Bobby Treat

-----Original Message-----
From: DrBob [mailto:majort at cox-internet.com] 
To: mathgroup at smc.vnet.net
Subject: [mg33907] [mg33894] RE: [mg33857] Need a algorithm


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: very simple plot format
  • Next by Date: Linking mathematica with VC++6.0
  • Previous by thread: RE: Need a algorithm
  • Next by thread: MathGL3D problem.....