I knocked my code out a bit sharpish. I am now using dodicat's range and I have 'cropped' the Knuth Shuffle.
@frisian Thanks for the Rosetta link.
52 card shuffle
-
- Posts: 4308
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: 52 card shuffle
Here is the original card shuffle (first post) without using the gmp library.
Note: I only changed four lines of code (Added the extra function and two macros of course, but besides that)
if randomize ,5 is not used both the gmp and my code give the same results.
I would guess only a handful of members use gmp.
I cannot be wrong with this assumption here because it depends on the size of the hand.<supposed to be a pun>
Here also is a factorial and rnd not using gmp.
I have used randomize ,5 but is it necessary?
I only need randoms between 48 and 57
randomize ,2 should do.
Code: Select all
Function _divide(n1 As String,n2 As String,decimal_places As integer=10,dpflag As String="s") As String
Dim As String number=n1,divisor=n2
dpflag=lcase(dpflag)
'For MOD
dim as integer modstop
if dpflag="mod" then
if len(n1)<len(n2) then return n1
if len(n1)=len(n2) then
if n1<n2 then return n1
end if
modstop=len(n1)-len(n2)+1
end if
if dpflag<>"mod" then
If dpflag<>"s" Then dpflag="raw"
end if
Dim runcount As integer
'_______ LOOK UP TABLES ______________
Dim Qmod(0 To 19) As Ubyte
Dim bool(0 To 19) As Ubyte
For z As Integer=0 To 19
Qmod(z)=(z Mod 10+48)
bool(z)=(-(10>z))
Next z
Dim answer As String 'THE ANSWER STRING
'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
part1=Mid$(s,1,position-1)
part2=Mid$(s,position)
s=part1+char+part2
End if
#endmacro
insert(answer,".",decpos)
answer=thepoint+zeros+answer
If dpflag="raw" Then
answer=Mid(answer,1,decimal_places)
End if
#endmacro
'______________________________________________
'__________ SPLIT A STRING ABOUT A CHARACTRR __________
Dim As String var1,var2
Dim pst As integer
#macro split(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Rtrim(Mid(stri,1,pst),".")
var2=Ltrim(Mid(stri,pst),".")
Else
var1=stri
End if
#endmacro
#macro Removepoint(s)
split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
If Left(number,1)="-" Then number=Ltrim(number,"-")
If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As integer lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)
If Instr(number,".") Then
Removepoint(number)
number=var1+var2
End if
If Instr(divisor,".") Then
Removepoint(divisor)
divisor=var1+var2
End if
Dim As integer numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As integer=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
Dim _sgn As Byte=-Sgn(decpos)
If _sgn=0 Then _sgn=1
Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
if dpflag<>"mod" then
If Len(zeros) =0 Then dpflag="s"
end if
Dim As integer runlength
If Len(zeros) Then
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
If dpflag="raw" Then
runlength=1
answer=String(Len(zeros)+runlength+10,"0")
If decimal_places>Len(zeros) Then
runlength=runlength+(decimal_places-Len(zeros))
answer=String(Len(zeros)+runlength+10,"0")
End If
End If
Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
End if
'___________DECIMAL POSITION DETERMINED _____________
'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")
Dim count As integer
Dim temp As String
Dim copytemp As String
Dim topstring As String
Dim copytopstring As String
Dim As integer lenf,lens
Dim As Ubyte takeaway,subtractcarry
Dim As integer n3,diff
If Ltrim(divisor,"0")="" Then Return "Error :division by zero"
lens=Len(divisor)
topstring=Left(number,lend)
copytopstring=topstring
Do
count=0
Do
count=count+1
copytemp=temp
Do
'___________________ QUICK SUBTRACTION loop _________________
lenf=Len(topstring)
If lens<lenf=0 Then 'not
If Lens>lenf Then
temp= "done"
Exit Do
End if
If divisor>topstring Then
temp= "done"
Exit Do
End if
End if
diff=lenf-lens
temp=topstring
subtractcarry=0
For n3=lenf-1 To diff Step -1
takeaway= topstring[n3]-divisor[n3-diff]+10-subtractcarry
temp[n3]=Qmod(takeaway)
subtractcarry=bool(takeaway)
Next n3
If subtractcarry=0 Then Exit Do
If n3=-1 Then Exit Do
For n3=n3 To 0 Step -1
takeaway= topstring[n3]-38-subtractcarry
temp[n3]=Qmod(takeaway)
subtractcarry=bool(takeaway)
if subtractcarry=0 then exit do
Next n3
Exit Do
Loop 'single run
temp=Ltrim(temp,"0")
If temp="" Then temp= "0"
topstring=temp
Loop Until temp="done"
' INDIVIDUAL CHARACTERS CARVED OFF ________________
runcount=runcount+1
If count=1 Then
topstring=copytopstring+Mid(number,lend+runcount,1)
Else
topstring=copytemp+Mid(number,lend+runcount,1)
End If
copytopstring=topstring
topstring=Ltrim(topstring,"0")
if dpflag="mod" then
if runcount=modstop then
if topstring="" then return "0"
return mid(topstring,1,len(topstring)-1)
end if
end if
answer[runcount-1]=count+47
If topstring="" And runcount>Len(n1)+1 Then
Exit Do
End if
Loop Until runcount=runlength+1
' END OF RUN TO REQUIRED DECIMAL PLACES
set(decimal) 'PUT IN THE DECIMAL POINT
'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
'NOW GET RID OF IT IF IT IS REDUNDANT
answer=Rtrim(answer,"0")
answer=Rtrim(answer,".")
answer=Ltrim(answer,"0")
If answer="" Then Return "0"
Return sign+answer
End Function
'=======================================================================
#define mod_(a,b) _divide((a),(b),,"mod")
#define div_(a,b) iif(len((a))<len((b)),"0",_divide((a),(b),-2))
'========================================================================
'A fairer shuffle of a deck of 52 cards.
'#Include Once "gmp_int.bi" 'used in large interger division
dim as byte a,b,count,pntr,cut
Dim Shared As string aa,Suit(0 to 3),rank(1 To 13),Player(1 To 4)
Dim Shared As String deck(1 to 52),Dividend,deal(1 To 4,1 To 13)
dim Shared As byte rndBounds(1 To 68),totDigits,cardNbr,suitNbr,rankNbr,n,i,j
Declare Function rndNbrs (Dividend As String="") As String
Declare sub unRank(Dividend As String,deck() As string)
Declare sub nbr2Card(deck() As string)
'data to represent 52!-1
DATA 8,0,6,5,8,1,7,5,1,7,0,9,4,3,8,7,8,5,7,1,6,6,0,6,3,6,8,5,6,4,0,3,7,6,6,9,7,5,2,8,9,5,0,5,4,4,0,8,8,3,2,7,7,8,2,3,9,9,9,9,9,9,9,9,9,9,9,9
DATA "A",2,3,4,5,6,7,8,9,10,"J","Q","K"
totDigits = 68 'total digits in 52!-1
n = 52 'cards
FOR a = 1 TO totDigits
read rndBounds(a) '0-n(whatever the upperbound is for the digit position)
NEXT a
'card values
For a=1 To 13
Read rank(a)
Next
'card symbols
Suit(0) = chr(3)
Suit(1) = chr(5)
Suit(2) = chr(4)
Suit(3) = chr(6)
rndNbrs(Dividend)
Print "Rank is (a 68 digit string): "
Print Dividend
unRank(Dividend,deck())
'allot suits and rank to cards
nbr2Card(deck())
PRINT "Above value unranked as :"
print
FOR a = 1 TO n
If asc(Right(deck(a),1))=3 Or asc(Right(deck(a),1))=4 Then
color 12, 15
Else
color 0, 15
End If
PRINT Using "\ \";deck(a); " ";
If a Mod 13 = 0 Then print
NEXT a
Print
sleep
end
'**************************************************************
'rndNbrs
Function rndNbrs(Dividend As String) As String
dim as byte a,rndDigit,upperBound
Randomize,5
upperBound = 0 'a switch from 0-n to 0 - 9 in rnd nbr generation
'rnd numbers for all 68 elements
FOR a = 1 TO totDigits
'upperbound digit - if rnd digit less, then all following rnd digits can be 0-9
IF upperBound <> 10 THEN upperBound = rndBounds(a) + 1
rndDigit = INT(RND * upperBound)
'test to see if rndDigit <Ubound & if so all following digits can be 0-9
IF rndDigit < rndBounds(a) THEN upperBound = 10
'concatenate the 68 random digits
dividend = dividend + STR(rndDigit)
NEXT a
Return Dividend
End Function
'**************************************************************
'transform a random 68 digit value into 52 different card values
Sub unRank(Dividend As String,deck() As String)
Dim As Byte i,j
Dim As String Quotient,Remainder,Divisor
dim as ulongint e,f
type gmp_int as string
Dim As gmp_int m
Dim As gmp_int p
deck(n) = "1" 'element 52
FOR i = n-1 TO 1 STEP -1 'n-1 to 1
Divisor = STR((n - i + 1))
m= dividend 'gmp_int(dividend)'used with gmp.bi
p=divisor 'gmp_int(divisor)
Quotient= div_(m,p) 'm\p
Remainder=mod_(m,p) ' m mod p
IF VAL(Remainder) = 0 THEN
Remainder = "1"
ELSE
e = VAL(Remainder) + 1
Remainder = STR(e)
END IF
deck(i) = Remainder
Dividend = Quotient
Quotient = ""
FOR j = i + 1 TO n
e = VAL(deck(j))
f = VAL(deck(i))
IF e >= f THEN
e = e + 1
deck(j) = STR(e)
END IF
NEXT j
NEXT i
end Sub
'**************************************************************
'the values 1 to 52 into card suits and rank
'1=AH...14=AC...27=AD...40=AS...52=KS
Sub nbr2Card(deck() As String)
Dim As Byte b
FOR b = 1 TO 52
cardNbr = Val(deck(b))-1'cardNbr - 1
suitNbr = cardNbr / 13' 0-3
rankNbr = (cardNbr MOD 13) + 1
deck(b)=rank(rankNbr)+suit(suitNbr)
Next b
End Sub
if randomize ,5 is not used both the gmp and my code give the same results.
I would guess only a handful of members use gmp.
I cannot be wrong with this assumption here because it depends on the size of the hand.<supposed to be a pun>
Here also is a factorial and rnd not using gmp.
Code: Select all
Function rndX(s1 As String) As String
#macro GetNumber
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
s[0]=range(48,s1[0])
For n As Long = 1 To L-1
s[n]=range(48,57)
Next
#endmacro
#macro compare(n1,n2,ans)
Scope
Var lenn1=Len(n1),lenn2=Len(n2)
If lenn1 > lenn2 Then ans=-1:Goto lbl
If lenn1 < lenn2 Then ans=0:Goto lbl
If n1 > n2 Then ans = -1 Else ans= 0
lbl:
End Scope
#endmacro
Dim As Long L=Len(s1),ans=1
Dim As String s=String(L,0)
While ans
GetNumber
compare(s,s1,ans)
Wend
Return Ltrim(s,"0")
End Function
Dim Shared As Ubyte _Mod_(0 To 99),_Div_(0 To 99)
For z As Long=0 To 99:_Mod_(z)=(z Mod 10+48):_Div_(z)=z\10:Next
Function factorial(num As Long) As String
Dim As String fact="1",a,b,c
Dim As Ubyte n,carry,ai
Dim As Long la,lb
For z As Long=1 To num
a=fact:b=Str(z):la=Len(a):lb=Len(b):c=String(la+lb,"0")
For i As Long =la-1 To 0 Step -1
carry=0:ai=a[i]-48
For j As Long =lb-1 To 0 Step -1
n =ai*(b[j]-48)+(c[i+j+1]-48)+carry
carry =_Div_(n):c[i+j+1]=_Mod_(n)
Next j
c[i]+=carry
Next i
fact=Ltrim(c,"0")
Next z
Return fact
End Function
Dim As string fac52 = factorial(52)
print fac52
print
randomize ,5
for n as long=1 to 15
print rndx(fac52)
next
sleep
I only need randoms between 48 and 57
randomize ,2 should do.
-
- Posts: 4308
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: 52 card shuffle
I am inclined to agree.dodicat wrote:randomize ,2 should do.
I still think that there is an awful lot of code there compared to my, now, 40 liner.
I don't want to be a party pooper but going back to the original code I think the algorithm is fundamentally flawed. It seems to me that there will be over 11% of permutation repetition. With my code, the number of permutations will be the true value.
I like your factorial function - it is blindingly fast. I went here to test some values. I never take anything on face value. <smile>
Re: 52 card shuffle
I was using ivorU's code.
I also would do it differently
I also would do it differently
Code: Select all
randomize timer,5
dim as string deck(1 to 52)={"a"+chr(3),"2"+chr(3),"3"+chr(3),"4"+chr(3),"5"+chr(3),"6"+chr(3),"7"+chr(3),"8"+chr(3),"9"+chr(3),"10"+chr(3),"j"+chr(3),"q"+chr(3),"k"+chr(3), _
"a"+chr(4),"2"+chr(4),"3"+chr(4),"4"+chr(4),"5"+chr(4),"6"+chr(4),"7"+chr(4),"8"+chr(4),"9"+chr(4),"10"+chr(4),"j"+chr(4),"q"+chr(4),"k"+chr(4),_
"a"+chr(5),"2"+chr(5),"3"+chr(5),"4"+chr(5),"5"+chr(5),"6"+chr(5),"7"+chr(5),"8"+chr(5),"9"+chr(5),"10"+chr(5),"j"+chr(5),"q"+chr(5),"k"+chr(5), _
"a"+chr(6),"2"+chr(6),"3"+chr(6),"4"+chr(6),"5"+chr(6),"6"+chr(6),"7"+chr(6),"8"+chr(6),"9"+chr(6),"10"+chr(6),"j"+chr(6),"q"+chr(6),"k"+chr(6)}
Sub shuffle(a() As string)
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
For n As Integer = lbound(a) To ubound(a)-1
Swap a(n), a(range(n,ubound(a)))
Next n
End Sub
sub show overload(a as string)
dim as long c=color
if instr(a,chr(3)) or instr(a,chr(4)) then color 12, 15 else color 0, 15
if len(a)=3 then
print ucase(left(a,2));right(a,1);" ";
else
print ucase(left(a,1));right(a,1);" ";
end if
color c,0
end sub
sub show overload(a() as string)
for n as long=1 to 52
show(a(n))
if n mod 13=0 then print
next
end sub
print "Original"
show deck()
for z as long=1 to 3
print "shuffled"
shuffle deck()
show deck()
next z
Dim As Ubyte v
v = Rnd*52
Print "I will pick a card, any card 1 To 52"
Print "I picked (from last shuffle) ";Str(v):show (deck(v)):print
print "done"
sleep
-
- Posts: 4308
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: 52 card shuffle
Yes. That is what I want to see - mine under pressure.
TechRadar ranking:
dodicat
deltarho[1859]
IvorU
Sorry, IvorU but when dodicat gets involved most of us have to step aside. He lives in Scotland but I wouldn't hold that against him. <smile>
TechRadar ranking:
dodicat
deltarho[1859]
IvorU
Sorry, IvorU but when dodicat gets involved most of us have to step aside. He lives in Scotland but I wouldn't hold that against him. <smile>
Re: 52 card shuffle
Excuse my ignorance: How do you make sure the random generator doesn't produce twice the same card?
-
- Posts: 4308
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: 52 card shuffle
When a card is drawn from the deck it is no longer in the deck so cannot be drawn again.
Re: 52 card shuffle
Yes - thanks for all the modifications and examples, I picked up quite a few hints.
@deltarho
Well second fellow is not too bad - better than being last...
I tried to find the highest factorial that GMP would give up on - it wouldn't handle factorial(200,000,000) but
digested factorial(150,000,000) and the output was a 1,161,269,521 digit number.
@deltarho
Well second fellow is not too bad - better than being last...
I tried to find the highest factorial that GMP would give up on - it wouldn't handle factorial(200,000,000) but
digested factorial(150,000,000) and the output was a 1,161,269,521 digit number.