25 Horses Problem
This is not from Rosetta Code but was a challenge for me since I found it on Internet. Got it working pretty good last night. It's one thing to know the answer another to code a sim of solution so it works for any set of 25 horses.
You need to find the 1st, 2nd and 3rd fastest of 25 horses but you can only race 5 horses at a time and you can not record their times only see how they place at end of race.
This was a Google Interview question, what is the minimum amount of races needed to be assured you know the 1st, 2nd, 3rd fastest. The answer was 7 but how do you code that problem, that was my challenge.
I have included a link in code where I encountered the problem and solution in the code comments at top. Update: which the forum editor proceeded to mess up! Here is link: https://www.google.com/search?client=ope...wpilM,st:0
Code: (Select All)
_Title "25 Horses" ' b+ 2022-09-06 revisit 2023-09-09
'ref
' https://www.google.com/search?client=ope...wpilM,st:0
' Of 25 horses which are top 3 runners?
' You can race up to 5 horses at a time but only learn their ranking 1st, 2nd, 3rd...
' What is the minimum number of races of 5 horses at a time?
' Answ = 7 but figure out why and then code it!
' debug or cheat by seeing the actual rates of each horse with race results
Debug = 1
Randomize Timer
Type horse
As Integer ID, rate, race, place
' ID is the horse number 1 to 25 before shuffling
' rate is number 1 to 25 rankings of horses to check with final answer found by code
' race helps track the group the horse was in in first 5 races
' place 2 or 3 if horse came in 2nd or 3rd in first 5 races
End Type
$Console:Only
Do
ReDim horses(1 To 25) As horse
ReDim rate(1 To 25)
' here are our horses secret ratings
For i = 1 To 25 ' load places 1 to 25
rate(i) = i
Next
For i = 25 To 2 Step -1
Swap rate(i), rate(Int(Rnd * i) + 1)
Next
For i = 1 To 25
horses(i).ID = i
horses(i).rate = rate(i)
horses(i).place = 0
'Print horses(i).ID, horses(i).rate
Next
ReDim race6(1 To 5) As horse ' setup to place winners in here
r6 = 0
For n = 1 To 5 ' first 5 races
ReDim group(1 To 5) As horse
Print: Print "Race:"; n
For i = 1 To 5
group(i).ID = horses((n - 1) * 5 + i).ID
group(i).rate = horses((n - 1) * 5 + i).rate
horses((n - 1) * 5 + i).race = n
'Print group(i).ID, group(i).rate
Next
QuickSort 1, 5, group() ' this is our running of the race and group is sorted by .rate
' show results pretend you see actual rating 2 item listed
place = 2
For i = 1 To 5
Print group(i).ID,
If Debug Then Print group(i).rate Else Print
If i = 1 Then ' setup race 6 with this winner
r6 = r6 + 1
race6(r6).ID = group(i).ID
race6(r6).rate = group(i).rate
race6(r6).race = 6
' Print: Print r6, race6(r6).ID, race6(r6).rate
End If
If i = 2 Or i = 3 Then ' record ones that also placed 2nd or 3rd
For j = 1 To 25
If horses(j).ID = group(i).ID Then horses(j).place = place: place = place + 1
Next
End If
Next
Next
Print: Print "Race: 6 Winners of First 5 Races"
'For i = 1 To 5 ' check race6
' Print race6(i).ID, race6(i).rate
'Next
QuickSort 1, 5, race6()
' the 7th race
'#1 is number 1 but 2nd, 3rd in it's first race could be actual 2, 3 = 2 horses for 7th
'#2 has to go again compare along it's 2nd in it's first race = 2 more horse for 7th
'#3 doesn't have anyone else from it's first race = 1 more horse for 7th
ReDim race7(1 To 5) As horse ' setup to load for 7th race
r7 = 0
For i = 1 To 5 ' report results race 6
Print race6(i).ID,
If Debug Then Print race6(i).rate Else Print
If i = 1 Then
FirstHorse = race6(i).ID
FirstRate = race6(i).rate
For j = 1 To 25
If horses(j).ID = race6(i).ID Then race = horses(j).race: Exit For
Next
For j = 1 To 25 ' find 2 also places in #1's first race
If horses(j).race = race And horses(j).place > 0 Then
r7 = r7 + 1
race7(r7).ID = horses(j).ID
race7(r7).rate = horses(j).rate
End If
Next
End If
If i = 2 Then ' this horse runs again
r7 = r7 + 1
race7(r7).ID = race6(i).ID
race7(r7).rate = race6(i).rate
For j = 1 To 25
If horses(j).ID = race6(i).ID Then race = horses(j).race: Exit For
Next
For j = 1 To 25 ' find 2 also places in #1's first race
If horses(j).race = race And horses(j).place = 2 Then ' get the horse that came 2nd
r7 = r7 + 1
race7(r7).ID = horses(j).ID
race7(r7).rate = horses(j).rate
End If
Next
End If
If i = 3 Then ' this last horse runs in the 7th
r7 = r7 + 1
race7(r7).ID = race6(i).ID
race7(r7).rate = race6(i).rate
End If
Next
Print: Print "Race: 7 Top Winner Already found but run the next 2 in it's first race"
Print " and Run the 2nd and the 2nd in it's first race, 5th horse is 3rd in 6th."
'For i = 1 To 5 ' check have 5 including 2 and 3
' Print race7(i).ID, race7(i).rate
'Next
QuickSort 1, 5, race7()
For i = 1 To 5 ' check have 5 includin 2 and 3
Print race7(i).ID,
If Debug Then Print race7(i).rate Else Print
If i = 1 Then SecondHorse = race7(i).ID: SecondRate = race7(i).rate
If i = 2 Then ThirdHorse = race7(i).ID: ThirdRate = race7(i).rate
Next
Print
Print " First Horse and rate ="; FirstHorse, FirstRate
Print "Second Horse and rate ="; SecondHorse, SecondRate
Print " Third Horse and rate ="; ThirdHorse, ThirdRate
Sleep
Cls
Loop Until _KeyDown(27)
Sub QuickSort (start As Long, finish As Long, array() As horse)
Dim Hi As Long, Lo As Long, Middle As Single
Hi = finish: Lo = start
Middle = array((Lo + Hi) / 2).rate 'find middle of array
Do
Do While array(Lo).rate < Middle: Lo = Lo + 1: Loop
Do While array(Hi).rate > Middle: Hi = Hi - 1: Loop
If Lo <= Hi Then
Swap array(Lo), array(Hi)
Lo = Lo + 1: Hi = Hi - 1
End If
Loop Until Lo > Hi
If Hi > start Then Call QuickSort(start, Hi, array())
If Lo < finish Then Call QuickSort(Lo, finish, array())
End Sub
You can run the code with debug on or off, when on you can see the actual ratings of each horse that I sort by with that sub. When off you can see the info presented by race number alone.
This is probably not going to be interesting until you try to code the solution yourself. Then your way will be better
Actually I think once I had horse ID I didn't have to look for race it first ran in, use same index to get that race and then see what other horses placed in that race. Maybe I will fix it later today. Update: That's exactly what I did! So code is good to go by me.Present code works well because 2nd and 3rd were found correctly even if they were in previous race with 1st or 2nd place of winners of race6.
b = b + ...