[VB6] - Lottery-Algorithm

[Zvoni]

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

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)

[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.

[Zvoni]

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?

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 ....

[si_the_geek]

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).

[Zvoni]

Cleaned up version of it:

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