52 card shuffle

[deltarho[1859]]

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.

[dodicat]

Here is the original card shuffle (first post) without using the gmp library.

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
  

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.

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 have used randomize ,5 but is it necessary?
I only need randoms between 48 and 57
randomize ,2 should do.

[deltarho[1859]]

randomize ,2 should do.

I am inclined to agree.

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>

[dodicat]

I was using ivorU's code.
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

 

  

[deltarho[1859]]

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>

[jj2007]

Excuse my ignorance: How do you make sure the random generator doesn't produce twice the same card?

[deltarho[1859]]

When a card is drawn from the deck it is no longer in the deck so cannot be drawn again.

[IvorU]

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.