+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Unique Random Array Program (/showthread.php?tid=3806)
Unique Random Array Program - eoredson - 07-09-2025
I got bored so I decided to test my programming skills.
Here is a simple program to fill an array of unique random numbers.
This is for making an array without duplicating similar values.
Also prompts to display duplicates and the unique array.
Code: (Select All)
Rem unique random array program. v1.0a QB64 PD source 2025.
Rem setup program and screen.
Option _ExplicitArray
$Checking:Off
Rem $Dynamic
DefLng A-Z
Randomize Timer
Const Version = "v1.0a"
_ScreenMove _Middle
_Title "Random Array Program"
Call Display.Status.Line(-1, "Random Array Program " + Version)
Screen 0
H = _Height
W = _Width
Locate H - 1, 1, 1
Rem start program.
Color 15
Print "Random Number Array List Program " + Version
Do
_Title "Random Array Program"
Color 12
Print "Array elements";
Input Num$
If Num$ = "" Then Exit Do
Num = Int(Val(Num$))
If Num <= 0 Then Num = 128
Print "List duplicates(y/n)?";
Do
_Limit 50
v$ = InKey$
If LCase$(v$) = "y" Then Print "y": Display = -1: Exit Do
If LCase$(v$) = "n" Then Print "n": Display = 0: Exit Do
Loop
Duplicates = 0
StartTimer = Timer
DotTimer = Timer
ReDim Array(1 To Num) As Long
Array(1) = Int(Rnd * Num + 1) ' seed initial value.
VarD = 0: VarE = 0: VarF! = Timer ' store display counters.
For Element = 2 To Num
' loop through array checking for duplicates.
Start:
If Display = 0 Then
TimeElapsed = Timer - DotTimer
If TimeElapsed >= 1& Then
DotTimer = Timer
_Title "Random Array Program" + Str$(Duplicates)
Call Dot.Display(VarD, VarE, VarF!)
End If
End If
Var = Int(Rnd * Num + 1)
For Test = 1 To Element - 1
If Array(Test) = Var Then
Duplicates = Duplicates + 1
If InKey$ = Chr$(27) Then
If Display = 0 Then
Call Clear.Dots
End If
Exit Do
End If
If Display Then
Color 15
Print "Duplicate("; LTrim$(Str$(Duplicates)); ")"; Test
End If
GoTo Start
End If
Next
Array(Element) = Var
Next
If Display = 0 Then
Call Clear.Dots
End If
TimeElapsed = Timer - StartTimer
Color 14
Print "Display array(y/n)?";
Do
_Limit 50
v$ = InKey$
If LCase$(v$) = "y" Then
Print "y"
Print "Unique array:";
For Var = 1 To Num
Print Array(Var);
Next
Print
Exit Do
End If
If LCase$(v$) = "n" Then
Print "n"
Exit Do
End If
Loop
Color 15
Print "Duplicates:"; Duplicates
Print "Elapsed time:"; TimeElapsed
Loop
Call Display.Status.Line(0, "")
Color 7
Print "End program."
End
Sub Dot.Display (VarA, VarB, VarC!)
Color 15
VarG! = Timer - VarC!
If VarG! < 0! Then VarG! = VarG! + 86400!
If VarG! >= 1! Then
VarC! = Timer
If VarA = 0 Then
VarB = VarB + 1
Print ".";
If VarB = 5 Then
VarA = -1
VarB = 0
End If
Else
VarB = VarB + 1
Call Back.Space
Print " ";
Call Back.Space
If VarB = 5 Then
VarA = 0
VarB = 0
End If
End If
End If
End Sub
Sub Clear.Dots
Do
If Pos(0) > 1 Then
Call Back.Space
Else
Exit Do
End If
Loop
End Sub
Sub Back.Space
If Pos(0) > 1 Then
Locate CsrLin, Pos(0) - 1, 0
Print " ";
Locate CsrLin, Pos(0) - 1, 1
End If
End Sub
Sub Display.Status.Line (Var, Var$)
' hopefully this is 80x25
Var2 = _Height
Var3 = _Width
If Var Then
Color 14, 1 ' hilight
Else
Color 15, 0 ' clear
End If
Locate Var2, 1, 0
VarZ$ = Var$ + Space$(Var3 - Len(Var$))
Print VarZ$;
Locate Var2 - 1, 1, 1
Color 15, 0
End SubLOC: 165
RE: Unique Random Array Program - bplus - 07-09-2025
Its very similar to shuffling a deck of cards which can be done in way less LOC!
In fact for range bottom to top for integers say 50 to 500, you want n amount random inetgers, say 100.
BRB!
RE: Unique Random Array Program - bplus - 07-09-2025
Code: (Select All)
top = 500
bottom = 50
n = 100
Randomize Timer
Print n; " random integers between:"; bottom; " and"; top
'create deck
Dim deck(bottom To top)
For i = bottom To top
deck(i) = i
Next
'shuffle it
For i = top To bottom + 1 Step -1
Swap deck(Int(Rnd * (i - bottom + 1)) + bottom), deck(i)
Next
'report
For i = 1 To n
Print deck(i + bottom);
NextI had to run it with this code to debug it to make sure top and bottom numbers were included:
Code: (Select All)
top = 60
bottom = 50
n = 10
Randomize Timer
Print n; " random integers between:"; bottom; " and"; top
'create deck
Dim deck(bottom To top)
For i = bottom To top
deck(i) = i
Next
'shuffle it
For i = top To bottom + 1 Step -1
Swap deck(Int(Rnd * (i - bottom + 1)) + bottom), deck(i)
Next
'report
For i = 1 To n
Print deck(i + bottom);
NextSo +1 to eric for my morning QB64 quiz!
Guess I was bored too
RE: Unique Random Array Program - eoredson - 07-09-2025
Ah, Heck! That is way easier then what I am doing:
(shuffle a deck of cards)..
You just helped me dwindle my code into 4 lines.
Code: (Select All)
Input n: Dim e(n)
For i = 1 To n: e(i) = i: Next
For i = 1 To n: Swap e(Int(Rnd * n + 1)), e(Int(Rnd * n + 1)): Next
For i = 1 To n: Print e(i);: NextRE: Unique Random Array Program - eoredson - 07-10-2025
While we are still on-topic, here is a card shuffle program:
Code: (Select All)
Rem program randomizes and displays a shuffled deck of cards.
Color 12
Print "Shuffle a deck of cards:"
n = 52: Dim e(n)
Randomize Timer
For i = 1 To n: e(i) = i: Next
For i = 1 To n: Swap e(Int(Rnd * n + 1)), e(Int(Rnd * n + 1)): Next
For i = 1 To 52
Color 15
Select Case e(i)
Case 1 To 13
q = e(i): GoSub DisplayCard
Print "Clubs"
Case 14 To 24
q = e(i) - 13: GoSub DisplayCard
Print "Hearts"
Case 25 To 37
q = e(i) - 24: GoSub DisplayCard
Print "Diamonds"
Case 38 To 52
q = e(i) - 37: GoSub DisplayCard
Print "Spades"
End Select
If (i Mod 13) = 0 Then
Color 14
Print "-more-";
Do
_Limit 50
If Len(InKey$) Then Print: Exit Do
Loop
End If
Next
Color 7
End
DisplayCard:
Select Case q
Case 1
Print "Ace";
Case 11
Print "Jack";
Case 12
Print "Queen";
Case 13
Print "King";
Case Else
Print q;
End Select
Print " of ";
ReturnRE: Unique Random Array Program - DANILIN - 07-10-2025
Similar topic: Guess My Number
https://qb64phoenix.com/forum/showthread.php?tid=900&page=2
Today still better
And from 2020: see you?
https://qb64forum.alephc.xyz/index.php?topic=4473.15