random number generator without resampling 1

[peter11]

I want to create a basic random number generator like
n = int(rnd * 9) but I want it to eliminate the numbers once they are selected.

for instance once it selects 5, next time it runs it should only be able to select 1-4 and 6-9. This should continue until there are no numbers remaining.

Thanks,
pete

 

[sunaj]

Hi,

Make an array with the numbers 1-10. Shuffle the values in the array and then step thorugh the array to get the random numbers.
There used to be a post that descriped several good methods to shuffle an array, but i can't find it. I'm sure that you'll finde something if you look around the web.

Sunaj
'The gap between theory and practice is not as wide in theory as it is in practice'

 

[sunaj]

Sub Shuffle(a, n)
Dim temp as Integer
Dim r as Integer
Dim i as Integer

For i = a To n
'Exchange a(i) with another (random) element
r = Int(Rnd) * n + 1
temp = a(i)
a(i) = a(r)
a(r) = temp
Next i
End Sub

Sunaj
'The gap between theory and practice is not as wide in theory as it is in practice'

 

[Jon4747]

Hi Peter,

What you need to do is store the used numbers in an array then check the array each time to see if its been used.
intCnt = 0
Randomize
While intCnt <= 8
intNum = Int(8 * Rnd()) + 1
For intC = 0 To 8
If intArr(intC) = intNum Then 'array for #'s used
intFlag = 1 ' # been used
End If
Next
If intFlag = 0 Then
' number is good
intArr(intCnt) = intNum
intCnt = intCnt + 1
End If
intFlag = 0
Wend

Jon

 

[WilMead]

Alter your view of the problem, you are selecting a random member from a set of available numbers.

This presents a two step operation.

First create a list of the numbers.

Second randomly generated numbers to select a number from the list. Base your random range on the lists size.

A VB collection gives you the tools you need to accomplish these tasks.



Wil Mead
wmead@optonline.net

 

[sunaj]

Hi Jon,

I know it is unlikely but the problem with your solution is that there is no guarentee that a certain number ever will come out, and the program will therefore end up in an endless loop.

Sunaj
'The gap between theory and practice is not as wide in theory as it is in practice'

 

[Guest_imported]

' Shuffle the elements of an array of any type
' (it doesn't work with arrays of objects or UDT)

Sub ArrayShuffle(arr As Variant)
Dim index As Long
Dim newIndex As Long
Dim firstIndex As Long
Dim itemCount As Long
Dim tmpValue As Variant

firstIndex = LBound(arr)
itemCount = UBound(arr) - LBound(arr) + 1

For index = UBound(arr) To LBound(arr) + 1 Step -1
' evaluate a random index from LBound to INDEX
newIndex = firstIndex + Int(Rnd * itemCount)
' swap the two items
tmpValue = arr(index)
arr(index) = arr(newIndex)
arr(newIndex) = tmpValue
' prepare for next iteration
itemCount = itemCount - 1
Next

End Sub

 

[Jon4747]

Hi Sunaj,

Your point is well taken, although I've never encountered that particular problem myself.

Jon

 

[WilMead]

[tt]
Sub it()
Const cnMaxElements = 20
Dim oSet As New Collection
Dim i As Integer

Debug.Print &quot;Start:&quot;; Timer
' Initialize the set
For i = 0 To cnMaxElements
oSet.Add i, Format(i, &quot;0&quot
Next i

Randomize
' Randomly select and remove members from set
While oSet.Count > 0
i = (Rnd * (oSet.Count - 1)) + 1
Debug.Print oSet.Item(i)
oSet.Remove i
Wend
Debug.Print &quot;Stop: &quot;; Timer

End Sub
[/tt]

Wil Mead
wmead@optonline.net

 

[Alt255]

Here's a slightly different approach.
Test the concept by adding a list box and a command button to a form. Then paste this code:
[tt]
Private Function UniqueRandomNumber _
(LowerBound, UpperBound, DecPlaces)
' This function uses a string variable
' to determine whether or not any
' given number has already been returned.
Static Test$

' Test for a function reset...
If LowerBound >= UpperBound Then
Test$ = &quot;&quot;
UniqueRandomNumber = UpperBound + 1
Exit Function
End If
LB = LowerBound + 1
Offset = Abs(1 - LB)
Range = (UpperBound + Offset) _
- (LB + Offset) + 1
Range = Range * (10 ^ DecPlaces)
If Test$ = &quot;&quot; Then
' This is ether the first time the
' function has been called or the
' function has been reset and
' called again.
Test$ = String$(Range, 255)
End If

' Try a few numbers to see
' if they are unused.
' (This will check only once
' in ranges over 499.)
For Rep = 1 To Fix(5 / Range * 100) + 1
Start = Int(Range * Rnd + 1)
If Mid$(Test$, Start, 1) = Chr$(255) Then
Found = Start
Mid$(Test$, Found, 1) = Chr$(0)
Exit For
End If
Next

' If that fails, pick the closest number.
If Found = 0 Then
' Search toward the end...
Found = InStr(Start, Test$, Chr$(255))
End If
If Found = 0 Then
' Search toward the beginning...
Found = InStrRev(Test$, Chr$(255), Start)
End If

' If a number was found...
If Found > 0 Then
' Mark the number as &quot;used&quot; and
' return it through the function.
Mid$(Test$, Found, 1) = Chr$(0)
UniqueRandomNumber = Found _
/ (10 ^ DecPlaces) + Offset
Else
' All numbers have been returned
' so reset the function.
Test$ = &quot;&quot;
UniqueRandomNumber = UpperBound + 1
End If

End Function



Private Sub Command1_Click()
List1.Clear
' The function returns numbers
' greater than LowerBound and equal to
' or less than UpperBound. In order to
' get all numbers with two decimal places
' from 1.24 to 9.91 you would....
LowerBound = 1.23
UpperBound = 9.91
DecPlaces = 2
Do While URI <= UpperBound
URI = UniqueRandomNumber _
(LowerBound, UpperBound, DecPlaces)
' The function returns a number greater
' than &quot;UpperBound&quot; when all numbers
' within the range have been returned.
If URI > UpperBound Then
Exit Do
Else
' Add the number to a list box.
List1.AddItem URI
End If
Loop

MsgBox &quot;Click to continue....&quot;
List1.Clear
' If you want to retrieve less than
' the entire list of numbers you would
' reset the function by setting
' LowerBound > UpperBound.
' Then call the function once
' for each number you require.
URI = UniqueRandomNumber(2, 1, 0)
' Get nine unique numbers
' between 5.2 and 20.2 (not inclusive):
LowerBound = 5.2
UpperBound = 20.1
DecPlaces = 1
For Re = 1 To 9
List1.AddItem UniqueRandomNumber _
(LowerBound, UpperBound, DecPlaces)
Next

MsgBox &quot;Click to continue....&quot;
List1.Clear
URI = UniqueRandomNumber(2, 1, 0)
' Get 100 non-repeating numbers from
' 100 to 1000:
LowerBound = 99
UpperBound = 1000
DecPlaces = 0
For Re = 1 To 100
List1.AddItem UniqueRandomNumber _
(LowerBound, UpperBound, DecPlaces)
Next

End Sub
[/tt]
As written, there are no provisions for including negative numbers in a range. Including such a feature should be a fairly simple task.

 

[littlebill46637]

refering to the post by sunaj (jan 20, 2002), the code posted would not work for me until I changed the line

for i = a to n

with

for i = 0 to n

due to a type mismatch error.

 

[MichaelRed]

The original question refers to the GENERATION of the (random) number set. The following will generate and return the set of unique INTEGERS in the range, specified for the input in random order. From earlier posts and some experience, all soloutions which test for the existance of a value eventually 'fail' as the time to test for the presence or the elements eventually becomes so tedious (e.g. LONG running) that the routine(s) are unsuitable. In general, the routines which test for (prior) inclusion of a value must generate a value which is not already in the list. As the list fills, this process has fewer values which are 'acceptable' for inclusion. Ultimately, there is only a single value which MUST be generated (for the last value), which for larger sets becomes unacceptablly tedious. For small sets (10 or 20 elements) the process is so trivial that the user may not note (or care about) the delay, however larger sets rapidly become acceptable from a performance (execution time) perspective.

Public Function basShuffleN(intNum As Integer) As Variant

    'To Return an Array of Integers (1 to intNum) which will be
    'filled with randomized integers in the range of 1 to intNum

    Dim PlaceArray() As Single
    Dim rtnArray() As Integer
    Dim Idx As Integer
    Dim Sorted As Boolean
    Dim strTemp As String

    ReDim PlaceArray(intNum, 2)
    ReDim rtnArray(intNum)

    'Create an array with the Integers and a Random Number
    For Idx = 1 To UBound(rtnArray)
        PlaceArray(Idx, 1) = Idx
        PlaceArray(Idx, 2) = Rnd()
    Next Idx

    'Sort acording to the Random Number
    Do While Not Sorted
        Sorted = True
        For Idx = 1 To UBound(PlaceArray) - 1
            If (PlaceArray(Idx, 2) > PlaceArray(Idx + 1, 2)) Then
                'Swap
                Sorted = False
                PlaceArray(0, 1) = PlaceArray(Idx, 1)
                PlaceArray(0, 2) = PlaceArray(Idx, 2)
                PlaceArray(Idx, 1) = PlaceArray(Idx + 1, 1)
                PlaceArray(Idx, 2) = PlaceArray(Idx + 1, 2)
                PlaceArray(Idx + 1, 1) = PlaceArray(0, 1)
                PlaceArray(Idx + 1, 2) = PlaceArray(0, 2)
            End If
        Next Idx
    Loop

    'Collect the 'Randomized" Integers into a String
    For Idx = 1 To UBound(PlaceArray, 1)
        rtnArray(Idx) = PlaceArray(Idx, 1)
    Next Idx

    'Return the delimited String
    basShuffleN = rtnArray

End Function

MichaelRed
m.red@att.net

Searching for employment in all the wrong places

 

[drctx]

MichaelRed,
very cool bit of code, works great. thanks

doug

 

[MichaelRed]

I 'feel like' reseurection ... two YEARS between posts! It might even be a record?





MichaelRed