Task: 100 prisoners








VB: Sub HundredPrisoners()

    NumberOfPrisoners = Int(InputBox("Number of Prisoners", "Prisoners", 100))
    Tries = Int(InputBox("Numer of Tries", "Tries", 1000))
    Selections = Int(InputBox("Number of Selections", "Selections", NumberOfPrisoners / 2))

    StartTime = Timer

    AllFoundOptimal = 0
    AllFoundRandom = 0
    AllFoundRandomMem = 0

    For i = 1 To Tries
        OptimalCount = HundredPrisoners_Optimal(NumberOfPrisoners, Selections)
        RandomCount = HundredPrisoners_Random(NumberOfPrisoners, Selections)
        RandomMemCount = HundredPrisoners_Random_Mem(NumberOfPrisoners, Selections)
        
        If OptimalCount = NumberOfPrisoners Then
            AllFoundOptimal = AllFoundOptimal + 1
        End If
        If RandomCount = NumberOfPrisoners Then
            AllFoundRandom = AllFoundRandom + 1
        End If
        If RandomMemCount = NumberOfPrisoners Then
            AllFoundRandomMem = AllFoundRandomMem + 1
        End If
    Next i


    ResultString = "Optimal: " & AllFoundOptimal & " of " & Tries & ": " & AllFoundOptimal / Tries * 100 & "%"
    ResultString = ResultString & Chr(13) & "Random: " & AllFoundRandom & " of " & Tries & ": " & AllFoundRandom / Tries * 100 & "%"
    ResultString = ResultString & Chr(13) & "RandomMem: " & AllFoundRandomMem & " of " & Tries & ": " & AllFoundRandomMem / Tries * 100 & "%"

    EndTime = Timer

    ResultString = ResultString & Chr(13) & "Elapsed Time: " & Round(EndTime - StartTime, 2) & " s"
    ResultString = ResultString & Chr(13) & "Trials/sec: " & Tries / Round(EndTime - StartTime, 2)

    MsgBox ResultString, vbOKOnly, "Results"

End Sub

Function HundredPrisoners_Optimal(ByVal NrPrisoners, ByVal NrSelections) As Long
    Dim DrawerArray() As Long
    
    ReDim DrawerArray(NrPrisoners - 1)
    
    For Counter = LBound(DrawerArray) To UBound(DrawerArray)
        DrawerArray(Counter) = Counter + 1
    Next Counter

    FisherYates DrawerArray
    
    For i = 1 To NrPrisoners
        NumberFromDrawer = DrawerArray(i - 1)
        For j = 1 To NrSelections - 1
            If NumberFromDrawer = i Then
                FoundOwnNumber = FoundOwnNumber + 1
                Exit For
            End If
            NumberFromDrawer = DrawerArray(NumberFromDrawer - 1)
        Next j
    Next i
    HundredPrisoners_Optimal = FoundOwnNumber
End Function

Function HundredPrisoners_Random(ByVal NrPrisoners, ByVal NrSelections) As Long
    Dim DrawerArray() As Long
    ReDim DrawerArray(NrPrisoners - 1)
    
    FoundOwnNumber = 0
    
    For Counter = LBound(DrawerArray) To UBound(DrawerArray)
        DrawerArray(Counter) = Counter + 1
    Next Counter

    FisherYates DrawerArray
    
    
    For i = 1 To NrPrisoners
        For j = 1 To NrSelections
            RandomDrawer = Int(NrPrisoners * Rnd)
            NumberFromDrawer = DrawerArray(RandomDrawer)
            If NumberFromDrawer = i Then
                FoundOwnNumber = FoundOwnNumber + 1
                Exit For
            End If
        Next j
    Next i
    HundredPrisoners_Random = FoundOwnNumber
End Function

Function HundredPrisoners_Random_Mem(ByVal NrPrisoners, ByVal NrSelections) As Long
    Dim DrawerArray() As Long
    Dim SelectionArray() As Long
    ReDim DrawerArray(NrPrisoners - 1)
    ReDim SelectionArray(NrPrisoners - 1)
    
    HundredPrisoners_Random_Mem = 0
    FoundOwnNumberMem = 0
    
    For Counter = LBound(DrawerArray) To UBound(DrawerArray)
        DrawerArray(Counter) = Counter + 1
    Next Counter
    
    For Counter = LBound(SelectionArray) To UBound(SelectionArray)
        SelectionArray(Counter) = Counter + 1
    Next Counter

    FisherYates DrawerArray
    
    For i = 1 To NrPrisoners
        FisherYates SelectionArray
        For j = 1 To NrSelections
            NumberFromDrawer = DrawerArray(SelectionArray(j - 1) - 1)
            If NumberFromDrawer = i Then
                FoundOwnNumberMem = FoundOwnNumberMem + 1
                Exit For
            End If
        Next j
    Next i
    HundredPrisoners_Random_Mem = FoundOwnNumberMem
End Function

Sub FisherYates(ByRef InputArray() As Long)
 
    Dim Temp As Long
    Dim PosRandom As Long
    Dim Counter As Long
    Dim Upper As Long
    Dim Lower As Long
     
    Lower = LBound(InputArray)
    Upper = UBound(InputArray)
     
    Randomize
     
    For Counter = Upper To (Lower + 1) Step -1
        PosRandom = CLng(Int((Counter - Lower + 1) * Rnd + Lower))
        Temp = InputArray(Counter)
        InputArray(Counter) = InputArray(PosRandom)
        InputArray(PosRandom) = Temp
    Next Counter
 
End Sub



Fortran: SUBROUTINE SHUFFLE_ARRAY(INT_ARRAY)
    
    
    IMPLICIT NONE

    INTEGER, DIMENSION(100), INTENT(INOUT) :: INT_ARRAY
    INTEGER, PARAMETER :: N_PASSES = 10
    

    INTEGER :: TEMP_1, TEMP_2   
    INTEGER :: I, J, PASS       
    REAL :: R                   

    CALL RANDOM_SEED()  

    DO PASS=1, N_PASSES
        DO I=1, SIZE(INT_ARRAY)

            
            CALL RANDOM_NUMBER(R)
            J = CEILING(R*SIZE(INT_ARRAY))

            
            
            DO WHILE (J > SIZE(INT_ARRAY))
                J = CEILING(R*SIZE(INT_ARRAY))
            END DO

            
            TEMP_1 = INT_ARRAY(I)
            TEMP_2 = INT_ARRAY(J)
            INT_ARRAY(I) = TEMP_2
            INT_ARRAY(J) = TEMP_1
        ENDDO
    ENDDO
END SUBROUTINE SHUFFLE_ARRAY

SUBROUTINE RUN_RANDOM(N_ROUNDS)
    
    
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N_ROUNDS 

    INTEGER :: ROUND, PRISONER, CHOICE, I       
    INTEGER :: N_SUCCESSES                      
    REAL(8) :: TOTAL                            
    LOGICAL :: NUM_FOUND = .FALSE.              

    INTEGER, DIMENSION(100) :: CARDS, CHOICES   
                                                

    
    
    
    
    CARDS = (/(I, I=1, 100, 1)/)
    CHOICES = (/(I, I=1, 100, 1)/)

    N_SUCCESSES = 0
    TOTAL = REAL(N_ROUNDS)

    
    
    
    
    ROUNDS_LOOP: DO ROUND=1, N_ROUNDS
        CALL SHUFFLE_ARRAY(CARDS)
        PRISONERS_LOOP: DO PRISONER=1, 100
            NUM_FOUND = .FALSE.
            CALL SHUFFLE_ARRAY(CHOICES)
            CHOICE_LOOP: DO CHOICE=1, 50
                IF(CARDS(CHOICE) == PRISONER) THEN
                    NUM_FOUND = .TRUE.
                    EXIT CHOICE_LOOP
                ENDIF
            ENDDO CHOICE_LOOP
            IF(.NOT. NUM_FOUND) THEN
                EXIT PRISONERS_LOOP
            ENDIF
        ENDDO PRISONERS_LOOP
        IF(NUM_FOUND) THEN
            N_SUCCESSES = N_SUCCESSES + 1
        ENDIF
    ENDDO ROUNDS_LOOP

    WRITE(*, '(A, F0.3, A)') "Random drawer selection method success rate: ", &
        100*N_SUCCESSES/TOTAL, "%"

END SUBROUTINE RUN_RANDOM

SUBROUTINE RUN_OPTIMAL(N_ROUNDS)
    
    
    
    
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N_ROUNDS

    INTEGER :: ROUND, PRISONER, CHOICE, I   
    INTEGER :: CURRENT_DRAW                 
    INTEGER :: N_SUCCESSES                  
    REAL(8) :: TOTAL                        
    LOGICAL :: NUM_FOUND = .FALSE.          
    INTEGER, DIMENSION(100) :: CARDS        

    
    
    CARDS = (/(I, I=1, 100, 1)/)

    N_SUCCESSES = 0
    TOTAL = REAL(N_ROUNDS)

    
    
    
    
    ROUNDS_LOOP: DO ROUND=1, N_ROUNDS
        CARDS = (/(I, I=1, 100, 1)/)
        CALL SHUFFLE_ARRAY(CARDS)
        PRISONERS_LOOP: DO PRISONER=1, 100
            CURRENT_DRAW = PRISONER
            NUM_FOUND = .FALSE.
            CHOICE_LOOP: DO CHOICE=1, 50
                IF(CARDS(CURRENT_DRAW) == PRISONER) THEN
                    NUM_FOUND = .TRUE.
                    EXIT CHOICE_LOOP
                ELSE
                    CURRENT_DRAW = CARDS(CURRENT_DRAW)
                ENDIF
            ENDDO CHOICE_LOOP
            IF(.NOT. NUM_FOUND) THEN
                EXIT PRISONERS_LOOP
            ENDIF
        ENDDO PRISONERS_LOOP
        IF(NUM_FOUND) THEN
            N_SUCCESSES = N_SUCCESSES + 1
        ENDIF
    ENDDO ROUNDS_LOOP
    WRITE(*, '(A, F0.3, A)') "Optimal drawer selection method success rate: ", &
        100*N_SUCCESSES/TOTAL, "%"

END SUBROUTINE RUN_OPTIMAL

PROGRAM HUNDRED_PRISONERS
    
    
    IMPLICIT NONE
    INTEGER, PARAMETER :: N_ROUNDS = 50000
    WRITE(*,'(A, I0, A)') "Running simulation for ", N_ROUNDS, " trials..."
    CALL RUN_RANDOM(N_ROUNDS)
    CALL RUN_OPTIMAL(N_ROUNDS)
END PROGRAM HUNDRED_PRISONERS