VBA - Jeu Bulls & Cows (Taureaux et vaches)

Novembre 2017




Règles

- Tous les chiffres dans le nombre secret sont différents.


- Si dans votre proposition il y a des chiffres du nombre secret, aux bons endroits, ils sont des Taureaux.
- Si dans votre proposition il y a des chiffres du nombre secret, mais pas aux bons endroits, ils sont des Vaches.

Jeu pour "Humains"

Option Explicit

Sub Bulls_and_cows()
Dim strNb As String, strIn As String, strMsg As String, strTemp As String
Dim boolEnd As Boolean
Dim lngCpt As Long
Dim i As Byte, bytCow As Byte, bytBull As Byte
Const NB_CHIFFRES As Byte = 4
Const MAX_ESSAIS As Byte = 25

    strNb = Nombre_Secret(NB_CHIFFRES)

    Do
        bytBull = 0: bytCow = 0: lngCpt = lngCpt + 1
        If lngCpt > MAX_ESSAIS Then strMsg = "Maximum d'essais atteind. Désolé partie perdue!": Exit Do
        strIn = Question(NB_CHIFFRES)
        If strIn = "Exit Game" Then strMsg = "Abandon utilisateur": Exit Do
        For i = 1 To Len(strNb)
            If Mid(strNb, i, 1) = Mid(strIn, i, 1) Then
                bytBull = bytBull + 1
            ElseIf InStr(strNb, Mid(strIn, i, 1)) > 0 Then
                bytCow = bytCow + 1
            End If
        Next i
        If bytBull = Len(strNb) Then
            boolEnd = True: strMsg = "Vous gagnez en " & lngCpt & " essais!"
        Else
            strTemp = strTemp & vbCrLf & "Avec : " & strIn & " ,vous avez : " & bytBull & " taureaux," & bytCow & " vaches."
            MsgBox strTemp
        End If
    Loop While Not boolEnd
    MsgBox strMsg
End Sub

Function Nombre_Secret(NbDigits As Byte) As String
Dim myColl As New Collection
Dim strTemp As String
Dim bytAlea As Byte

    Randomize
    Do
        bytAlea = Int((Rnd * 9) + 1)
        On Error Resume Next
        myColl.Add CStr(bytAlea), CStr(bytAlea)
        If Err <> 0 Then
            On Error GoTo 0
        Else
            strTemp = strTemp & CStr(bytAlea)
        End If
    Loop While Len(strTemp) < NbDigits
    Nombre_Secret = strTemp
End Function

Function Question(NbDigits As Byte) As String
Dim boolGood As Boolean, strIn As String, i As Byte, NbDiff As Byte

    Do While Not boolGood
        strIn = InputBox("Entrez un nombre (à " & NbDigits & " chiffres)", "Nombre")
        If StrPtr(strIn) = 0 Then strIn = "Exit Game": Exit Do
        If strIn <> "" Then
            If Len(strIn) = NbDigits Then
                NbDiff = 0
                For i = 1 To Len(strIn)
                    If Len(Replace(strIn, Mid(strIn, i, 1), "")) < NbDigits - 1 Then
                        NbDiff = 1
                        Exit For
                    End If
                Next i
                If NbDiff = 0 Then boolGood = True
            End If
        End If
    Loop
    Question = strIn
End Function

Jeu joué par ordinateur

Option Explicit
 
Sub Main_Bulls_And_Cows_Player()
Dim collSoluces As New Collection, Elem As Variant, Soluce As String
Dim strNumber As String, cpt As Byte, P As Byte
Dim i As Byte, Bulls() As Boolean, NbBulls As Byte, Cows As Byte, Poss As Long
Const NUMBER_OF_DIGITS As Byte = 4
 
        strNumber = CreateNb(NUMBER_OF_DIGITS)
        Debug.Print "TIRAGE : " & StrConv(strNumber, vbUnicode)
        Debug.Print "---------- DEBUT ------------"
        Set collSoluces = CollOfPossibleNumbers
        Poss = collSoluces.Count
        For Each Elem In collSoluces
            Debug.Print "Tentative : " & StrConv(Elem, vbUnicode)
            NbBulls = 0: Soluce = Elem
            ReDim Bulls(NUMBER_OF_DIGITS - 1)
            For i = 1 To NUMBER_OF_DIGITS
                If IsBull(strNumber, Mid(Elem, i, 1), i) Then
                    Bulls(i - 1) = True: NbBulls = NbBulls + 1
                    RemoveIfNotBull collSoluces, Mid(Elem, i, 1), i
                End If
            Next i
            Cows = 0
            For i = 1 To NUMBER_OF_DIGITS
                If Not Bulls(i - 1) Then
                    If IsCow(collSoluces, strNumber, Mid(Elem, i, 1), P) Then
                        If Not Bulls(P - 1) Then Cows = Cows + 1
                    End If
                End If
            Next i
            Poss = collSoluces.Count
            Debug.Print "Taureaux : " & NbBulls & ", Vaches : " & Cows
            If Poss = 1 Then Exit For
        Next
                Debug.Print "---------- FIN ------------"
        Debug.Print "LE TIRAGE EST : " & StrConv(strNumber, vbUnicode) & " nombre secret trouvé : " & StrConv(Soluce, vbUnicode)
End Sub
 
Function CreateNb(NbDigits As Byte) As String
Dim myColl As New Collection
Dim strTemp As String
Dim bytAlea As Byte
 
    Randomize
    Do
        bytAlea = Int((Rnd * 9) + 1)
        On Error Resume Next
        myColl.Add CStr(bytAlea), CStr(bytAlea)
        If Err <> 0 Then
            On Error GoTo 0
        Else
            strTemp = strTemp & CStr(bytAlea)
        End If
    Loop While Len(strTemp) < NbDigits
    CreateNb = strTemp
End Function
 
Function CollOfPossibleNumbers() As Collection
Dim TempColl As New Collection
Dim x As String
Dim i As Long
Dim Flag As Boolean
Dim B As Byte
 
    For i = 1234 To 9876
        Flag = False
        For B = 1 To 4
            x = CStr(i)
            If Len(Replace(x, Mid(x, B, 1), "")) < 3 Then
                Flag = True: Exit For
            End If
        Next
        If Not Flag Then TempColl.Add x, x
    Next i
    Set CollOfPossibleNumbers = TempColl
End Function
 
Function IsBull(strgNb As String, Digit As String, place As Byte) As Boolean
    IsBull = (Mid(strgNb, place, 1) = Digit)
End Function
 
Function IsCow(C As Collection, strgNb As String, Digit As String, place As Byte) As Boolean
    If (InStr(strgNb, Digit) > 0) Then
        IsCow = True: place = InStr(strgNb, Digit)
        RemoveIfNotCow C, Digit
    End If
End Function
 
Sub RemoveIfNotBull(C As Collection, Digit As String, place As Byte)
Dim E As Variant
 
    For Each E In C
        If Mid(E, place, 1) <> Digit Then C.Remove E
    Next
End Sub
 
Sub RemoveIfNotCow(C As Collection, Digit As String)
Dim E As Variant
 
    For Each E In C
        If (InStr(E, Digit) = 0) Then C.Remove E
    Next
End Sub

Publié par pijaku.
Ce document intitulé «  VBA - Jeu Bulls & Cows (Taureaux et vaches)  » issu de CommentCaMarche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.