[VB6] - Lottery-Algorithm
On a german Forum I developed the following Lottery-Algorithm (which i haven't found on the Internet in this form).
I would like to hear your opinions and/or suggestions to improve it
EDIT: cleaned up Version: https://www.vbforums.com/showthread....=1#post5556369
vb Code:
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Sub Lottery(ByVal DrawNumbers As Long, ByVal TotalNumbers As Long)
Dim arrSource() As Long
Dim arrDest() As Long
Dim i As Long
Dim j As Long
Dim Counter As Long
Dim RandomNumber As Long
'What Lottery is played
ReDim arrDest(1 To DrawNumbers)
ReDim arrSource(1 To TotalNumbers)
'Create Source-Array
For i = 1 To TotalNumbers
arrSource(i) = i
Next
Counter = 0
Randomize
Do
RandomNumber = Int(UBound(arrSource) * Rnd + 1)
Counter = Counter + 1
arrDest(Counter) = arrSource(RandomNumber)
'Cutting out the RandomNumber drawn
For j = RandomNumber + 1 To UBound(arrSource)
CopyMemory arrSource(j - 1), arrSource(j), 4
Next
'Cut down the Source-Array
ReDim Preserve arrSource(1 To UBound(arrSource) - 1)
Loop Until Counter = DrawNumbers
For i=1 to DrawNumbers
Debug.Print arrDest(i)
Next
End Sub
'Calling the function with
Call Lottery (6, 49)
Re: [VB6] - Lottery-Algorithm
That is generally good, but there are a couple of relatively minor issues.
While CopyMemory has its uses, moving one Long (even if done 49*6 times in total) is not worth it - the overhead of calling an API outweighs the speed benefit.
On a semi-related note, ReDim Preserve is one of the slowest things you can do, so if you care about speed, try to avoid it. One way is to use a variable to indicate the "ubound" position, and when you want to remove an item just move the item at "ubound" to it, then decrease the "ubound" variable. In cases like this one (where you create the array only to add/remove items), a Collection may be a better idea.
Re: [VB6] - Lottery-Algorithm
Quote:
Originally Posted by
si_the_geek
That is generally good, but there are a couple of relatively minor issues.
While CopyMemory has its uses, moving one Long (even if done 49*6 times in total) is not worth it - the overhead of calling an API outweighs the speed benefit.
On a semi-related note, ReDim Preserve is one of the slowest things you can do, so if you care about speed, try to avoid it. One way is to use a variable to indicate the "ubound" position, and when you want to remove an item just move the item at "ubound" to it, then decrease the "ubound" variable. In cases like this one (where you create the array only to add/remove items), a Collection may be a better idea.
Hi Si,
thx for the idea.
You mean something like this?
vb Code:
Sub Lottery(ByVal DrawNumbers As Long, ByVal TotalNumbers As Long)
Dim arrSource() As Long
Dim arrDest() As Long
Dim i As Long
Dim UpperBound As Long
Dim Counter As Long
Dim RandomNumber As Long
'What Lottery is played
ReDim arrDest(1 To DrawNumbers)
ReDim arrSource(1 To TotalNumbers)
'Create Source-Array
For i = 1 To TotalNumbers
arrSource(i) = i
Next
Counter = 0
UpperBound = TotalNumbers
Randomize
Do
RandomNumber = Int(UpperBound * Rnd + 1)
Counter = Counter + 1
arrDest(Counter) = arrSource(RandomNumber)
'Swapping the RandomNumber drawn with the Number at UpperBound
arrSource(RandomNumber) = arrSource(UpperBound)
UpperBound = UpperBound - 1
Loop Until Counter = DrawNumbers
For i = 1 To DrawNumbers
Debug.Print arrDest(i)
Next
End Sub
'Calling the function with
Call Lottery(6, 49)
As for the Collection-Object: I plainly dislike it, and i wouldn't be able to give you a reason for it ....:D
Re: [VB6] - Lottery-Algorithm
That's it. :)
I can understand not liking the Collection as it isn't great in terms of a general-purpose tool, but it does have its uses - and in situations like this it can often be quicker (but for such a small data set, that wont matter).
Re: [VB6] - Lottery-Algorithm
Cleaned up version of it:
Code:
Sub CallLottery()
Dim arrLottery() As Long
arrLottery = Lottery(10, 49, True, False, 40) 'order unimportant, no duplicates --> Classic Lottery, in this case: Pick 10 Numbers from 40 to 49
arrLottery = Lottery(6, 49, True, True) 'order unimportant, with duplicates
arrLottery = Lottery(6, 49, False, False) 'order important, no duplicates --> Raffle, Horse-Race --> a call "Lottery(52, 52, False, False)" would be a full shuffle of a deck of cards
arrLottery = Lottery(6, 49, False, True) 'order important, with duplicates --> Password-Generator?
End Sub
Public Function Lottery(ByVal DrawNumbers As Long, ByVal TotalNumbers As Long, Optional ByVal Sorted As Boolean = True, Optional ByVal Duplicates As Boolean = False, Optional ByVal LowerBound As Long = 1) As Long()
Dim arrSource() As Long
Dim arrDest() As Long
Dim i As Long
Dim UpperBound As Long
Dim Counter As Long
Dim RandomNumber As Long
'Redim Arrays according to Arguments
ReDim arrDest(1 To DrawNumbers)
ReDim arrSource(LowerBound To TotalNumbers)
'Build Source-Array
For i = LBound(arrSource) To UBound(arrSource)
arrSource(i) = i
Next
Counter = 0
UpperBound = UBound(arrSource)
Randomize
Do
RandomNumber = Int((UpperBound - LowerBound) * Rnd + LowerBound)
Counter = Counter + 1
arrDest(Counter) = arrSource(RandomNumber)
If Not Duplicates Then
'Swap drawn member with highest remaining member of Source-Array
arrSource(RandomNumber) = arrSource(UpperBound)
'reduce "virtually" the Source-Array
UpperBound = UpperBound - 1
End If
Loop Until Counter = DrawNumbers
If Sorted Then QuickSort arrDest
Lottery = arrDest
End Function
Public Sub QuickSort(vSort As Variant, Optional ByVal lngStart As Variant, Optional ByVal lngEnd As Variant)
If IsMissing(lngStart) Then lngStart = LBound(vSort)
If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Variant
i = lngStart: j = lngEnd
x = vSort((lngStart + lngEnd) / 2)
Do
Do While (LCase(vSort(i)) < LCase(x)): i = i + 1: Loop
Do While (LCase(vSort(j)) > LCase(x)): j = j - 1: Loop
If (i <= j) Then
h = vSort(i)
vSort(i) = vSort(j)
vSort(j) = h
i = i + 1: j = j - 1
End If
Loop Until (i > j)
If (lngStart < j) Then QuickSort vSort, lngStart, j
If (i < lngEnd) Then QuickSort vSort, i, lngEnd
End Sub