Task: Bulls and cows_Player








VB: 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 "TOSS : " & StrConv(strNumber, vbUnicode)
        Debug.Print "---------- START ------------"
        Set collSoluces = CollOfPossibleNumbers
        Poss = collSoluces.Count
        For Each Elem In collSoluces
            
            Debug.Print "Attempt : " & 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 "Bulls : " & NbBulls & ", Cows : " & Cows
            If Poss = 1 Then Exit For
        Next
                Debug.Print "---------- THE END ------------"
        Debug.Print "TOSS WAS : " & StrConv(strNumber, vbUnicode) & " We found : " & 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



Fortran: module Player
  implicit none

contains

subroutine Init(candidates)
  integer, intent(in out) :: candidates(:)
  integer :: a, b, c, d, n
    
           n = 0
thousands: do a = 1, 9
hundreds:    do b = 1, 9
tens:          do c = 1, 9
units:           do d = 1, 9
                   if (b == a) cycle hundreds
                   if (c == b .or. c == a) cycle tens
                   if (d == c .or. d == b .or. d == a) cycle units
                   n = n + 1
                   candidates(n) = a*1000 + b*100 + c*10 + d
                 end do units
               end do tens
             end do hundreds
           end do thousands

end subroutine init

subroutine Evaluate(bulls, cows, guess, candidates) 
  integer, intent(in) :: bulls, cows, guess
  integer, intent(in out) :: candidates(:)
  integer :: b, c, s, i, j
  character(4) :: n1, n2
   
  write(n1, "(i4)") guess
  do i = 1, size(candidates)
    if (candidates(i) == 0) cycle
    b = 0
    c = 0
    write(n2, "(i4)") candidates(i)
    do j = 1, 4
      s = index(n1, n2(j:j)) 
      if(s /= 0) then
        if(s == j) then
          b = b + 1
        else
          c = c + 1
        end if
      end if
    end do
    if(.not.(b == bulls .and. c == cows)) candidates(i) = 0
  end do
end subroutine Evaluate

function Nextguess(candidates)
  integer :: Nextguess
  integer, intent(in out) :: candidates(:)
  integer :: i

  nextguess = 0
  do i = 1, size(candidates)
    if(candidates(i) /= 0) then
      nextguess = candidates(i)
      candidates(i) = 0
      return
     end if
  end do
end function
end module Player

program Bulls_Cows
  use Player
  implicit none

  integer :: bulls, cows, initial, guess
  integer :: candidates(3024) = 0
  real :: rnum


  call Init(candidates)


  call random_seed
  call random_number(rnum)
  initial = 3024 * rnum + 1
  guess = candidates(initial)
  candidates(initial) = 0
  
  do 
    write(*, "(a, i4)") "My guess is ", guess
    write(*, "(a)", advance = "no") "Please score number of Bulls and Cows: "
    read*, bulls, cows
    write(*,*)
    if (bulls == 4) then
      write(*, "(a)") "Solved
      exit
    end if



    call Evaluate(bulls, cows, guess, candidates)


    guess = Nextguess(candidates)
    if(guess == 0) then

      write(*, "(a)") "Sorry
      exit
    end if
  end do
end program