QB64 Phoenix Edition
Rosetta Code Challenges - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Rosetta Code Challenges (/showthread.php?tid=212)

Pages: 1 2

RE: Rosetta Code Challenges - bplus - 11-01-2022

@MasterGy

When checking over your code, I could not figure out this part:
Code: (Select All)
For t2 = 1 To 12
    add = add + Abs(ans(t2) = quest(t2))
    count = count + 1
Next t2

If add + 1 = count Then  '??? <<< add = count for perfect match with ans() to 12 statements
    Print "find:  ";:
    For t3 = 1 To 12 Step 1
        If ans(t3) Then Print t3;
    Next t3
    Print
End If
Shouldn't add = 12 (=count) for a perfect match with your ans() from binary conversion of numbers 0 to 4095.
If add + 1 = 12 you are allowing near misses which gets you extra credit at RC but you really want to see and mark the solution.

Also how you handled statement 4 and 8 is very different than mine and I don't even know or want to try equivalent of 2 And's between 3 ans().

' 4.  If statement 5 is true, then statements 6 and 7 are both true. 
Code: (Select All)
Case 4: ans = ans(5) And ans(6) And ans(7)


RE: Rosetta Code Challenges - bplus - 11-05-2022

Zebra Puzzle 2 Sweep

I rewrote the Zebra Puzzle because I was feeling guilty reviewing the results of last round of scenario elimination and coding the next. Good for practice but this really solves it blindly.

Now it's coded to eliminate scenarios by coding in what I was looking for and doing the elimination from there. To do that I needed to know where each house number started and ended so I kept the original scenario array at 15625 and just added an " X" to the end of it when that scenario was eliminated. This takes longer because I am running through 15625 scenarios at each round and for neighbor checks at each solved neighbor value that has a condition in the 16 Clues. The Build works much better and can be used to generate a list of permutations for all kinds of things.

Code: (Select All)
Option _Explicit
_Title "Zebra Puzzle 2 Sweep" 'b+ start 2021-09-05 2022-10-29
' ref  http://rosettacode.org/wiki/Zebra_puzzle
' restart 2022-10-27 add split
' 2022-10-29 make and use build sub for combining and ordering permutations
' generate ALL possible scenarios of house 1 number/order, 2 color, 3 nation, 4 drink, 5 smoke, 6 animal
' 2022-10-29 add old Wrd$() tool to find nth word in string.
' 2022-10-29 add Sub aCopy (a() As String, b() As String)
' 2022-10-29 add Sub AddEnd (a() As String, addon As String)
' 2022-10-29 3 phases of elimination and down to Sol'n in blink of the eye!

' 2022-11-02 Zebra Puzzle 2 Sweep is an attempt to code the observations I made between 3 eliminations rounds
' After first elimination from 15625 to 38 I observed House 1 had to be yellow, water Dunhills
' Add a Shared Solution Array and a sub that reads through survivor scenarios and looks for only 1 option for a house
' eg house 1 is only yellow so put yellow under color for house 1 and remove all other houses with yellow as option

' 2022-11-03 Since I am rebuilding this I want to do the build over too, more like I did in JB translation.
' 2022-11-04 OK it runs through supposedly without assistance by programmer.

$Console:Only
Print
Print "      The Zebra Puzzle has 16 Clues:"
Print
Print "  1.  There are five houses."
Print "  2.  The English man lives in the red house."
Print "  3.  The Swede has a dog."
Print "  4.  The Dane drinks tea."
Print "  5.  The green house is immediately to the left of the white house."
Print "  6.  They drink coffee in the green house."
Print "  7.  The man who smokes Pall Mall has birds."
Print "  8.  In the yellow house they smoke Dunhill."
Print "  9.  In the middle house they drink milk."
Print " 10.  The Norwegian lives in the first house."
Print " 11.  The man who smokes Blend lives in the house next to the house with cats."
Print " 12.  In a house next to the house where they have a horse, they smoke Dunhill."
Print " 13.  The man who smokes Blue Master drinks beer."
Print " 14.  The German smokes Prince."
Print " 15.  The Norwegian lives next to the blue house."
Print " 16.  They drink water in a house next to the house where they smoke Blend"
Print
Print "      The Puzzle is, Who owns the zebra?"
Print

Dim Shared Soln$(1 To 6, 1 To 5), Flag$ ' quality columns and house number rows
Dim Shared order$, color$, nation$, drink$, smoke$, animal$, testC$, testH$
Dim As Long i, test1, test2
Dim startT

' from 1-16 there are 5 house in order from left to right that have:
order$ = "1 2 3 4 5" 'left to right
color$ = "red green white yellow blue"
nation$ = "English Swede Dane Norwegian German"
drink$ = "tea coffee milk beer water"
smoke$ = "Pall_Malls Dunhill Blend Blue_Master Prince"
animal$ = "dog birds cats horse zebra?"

Print " 15,625 = (5 ^ 6) possible scenarios of :"
Print "               5 House Choices: "; order$
Print "         with 5 Colors Choices: "; color$
Print "  with 5 Nationalities Choices: "; nation$
Print "          with 5 Drink Choices: "; drink$
Print "         with 5 Smokes Choices: "; smoke$
Print " and finally 5 Animals Choices: "; animal$
Print
ReDim Shared scen$(1 To 1) ' container for all the permutations   make this shared so sub can use without parameter

' that built as I want list: order color nation drink smoke animal = 6 items in order
' note: at moment temp$ and scen$ arrays are the same
startT = Timer(.01)
Build animal$
Build smoke$
Build drink$
Build nation$
Build color$
Build order$

For i = 1 To UBound(scen$) ' elimination round

    '2.  The English man lives in the red house.
    test1 = InStr(scen$(i), "English") > 0: test2 = InStr(scen$(i), "red") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '3.  The Swede has a dog.
    test1 = InStr(scen$(i), "Swede") > 0: test2 = InStr(scen$(i), "dog") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '4.  The Dane drinks tea.
    test1 = InStr(scen$(i), "Dane") > 0: test2 = InStr(scen$(i), "tea") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '5.  The green house is immediately to the left of the white house.
    ' green <> 1, 2 or 5  so 3 or 4  white 4 or 5  because blue is 2 and green and white are sequential
    testC$ = Wrd$(scen$(i), 2): testH$ = Wrd$(scen$(i), 1)
    If testC$ = "green" Then
        If testH$ = "3" Or testH$ = "4" Then Else scen$(i) = scen$(i) + " X"
    ElseIf testC$ = "white" Then
        If testH$ = "4" Or testH$ = "5" Then Else scen$(i) = scen$(i) + " X"
    End If
    ' house 4 can only be green or white or wont have sequence
    If testH$ = "4" Then
        If testC$ = "green" Or testC$ = "white" Then Else scen$(i) = scen$(i) + " X"
    End If

    '6.  They drink coffee in the green house.
    test1 = InStr(scen$(i), "coffee") > 0: test2 = InStr(scen$(i), "green") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '7.  The man who smokes Pall Mall has birds.
    test1 = InStr(scen$(i), "Pall_Malls") > 0: test2 = InStr(scen$(i), "birds") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '8.  In the yellow house they smoke Dunhill.
    test1 = InStr(scen$(i), "yellow") > 0: test2 = InStr(scen$(i), "Dunhill") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '9.  In the middle house they drink milk.
    test1 = InStr(scen$(i), "3") > 0: test2 = InStr(scen$(i), "milk") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '10.  The Norwegian lives in the first house.
    test1 = InStr(scen$(i), "Norwegian") > 0: test2 = InStr(scen$(i), "1") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '11.  The man who smokes Blend lives in the house next to the house with cats.
    test1 = InStr(scen$(i), "Blend") > 0: test2 = InStr(scen$(i), "cats") > 0
    If test1 Or test2 Then ' not in same house
        If test1 And test2 Then scen$(i) = scen$(i) + " X"
    End If

    '12.  In a house next to the house where they have a horse, they smoke Dunhill.
    test1 = InStr(scen$(i), "horse") > 0: test2 = InStr(scen$(i), "Dunhill") > 0
    If test1 Or test2 Then ' not in same house
        If test1 And test2 Then scen$(i) = scen$(i) + " X"
    End If

    '13.  The man who smokes Blue Master drinks beer.
    test1 = InStr(scen$(i), "Blue_Master") > 0: test2 = InStr(scen$(i), "beer") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '14.  The German smokes Prince.
    test1 = InStr(scen$(i), "German") > 0: test2 = InStr(scen$(i), "Prince") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    '15.  The Norwegian lives next to the blue house.
    '     the Norwegian is in house 1 so blue house is house 2
    test1 = InStr(scen$(i), "blue") > 0: test2 = InStr(scen$(i), "2") > 0
    If test1 Or test2 Then ' if have one must have both or dump
        If test1 And test2 Then Else scen$(i) = scen$(i) + " X"
    End If

    ' 16. They drink water in a house next to the house where they smoke Blend
    test1 = InStr(scen$(i), "water") > 0: test2 = InStr(scen$(i), "Blend") > 0
    If test1 Or test2 Then ' not in same house
        If test1 And test2 Then scen$(i) = scen$(i) + " X"
    End If

Next
showScen ' OK  still works with 38 surv after first elim
Print String$(80, "+")
Print
Do
    Flag$ = ""
    EvalElimRun
    If Flag$ <> "" Then Print Flag$
    If Flag$ <> "" Then showScen
Loop Until Flag$ = ""
Print Timer(.01) - startT ' aprox 5.6 secs without printing
Print: Print String$(80, "="): Print
showSolution

Function House& (val$)
    Dim As Long row, col
    For row = 1 To 5
        For col = 1 To 6
            If Soln$(col, row) = val$ Then House& = row: Exit Function
        Next
    Next
End Function

Sub showSolution
    Dim As Long row, col
    Print pad$("House"); pad$("Color"); pad$("Nation"); pad$("Drink"); pad$("Smoke"); pad$("Pet")
    Print
    For row = 1 To 5
        For col = 1 To 6
            Print pad$(Soln$(col, row));
        Next
        Print
    Next
End Sub

Function pad$ (s$)
    pad$ = Left$(s$ + String$(13, " "), 13)
End Function

Sub EvalElimRun ' here I coded what I coded manually before supposedly without knowing what is going to sieve through
    Dim As Long s, h, item
    Dim H$
    For h = 1 To 5
        H$ = _Trim$(Str$(h))
        s = (h - 1) * 3125 + 1
        ' find first house still in the running
        While Wrd$(scen$(s), 7) = "X" And s < h * 3125
            s = s + 1
        Wend ' still active

        ReDim first$(1 To 6) ' get it's values
        For item = 1 To 6
            first$(item) = Wrd$(scen$(s), item) ' get first values for house
        Next
        ' if all values match first we have exclusive
        ReDim NoMatch(1 To 6) As Long
        s = s + 1
        While s <= h * 3125 ' run through section with house # h check if items match the very first active found
            If Wrd$(scen$(s), 7) <> "X" Then ' scen s still in running
                For item = 1 To 6
                    If NoMatch(item) = 0 Then ' so far all these are matching
                        If first$(item) <> Wrd$(scen$(s), item) Then NoMatch(item) = 1 ' dang
                    End If
                Next
            End If
            s = s + 1
        Wend

        ' process matches
        For item = 1 To 6
            If NoMatch(item) = 0 Then ' found something unique for house!
                If Soln$(item, h) = "" Then ' did we already know?
                    Soln$(item, h) = first$(item)
                    ' now throw out every other scen$ with that item in another house
                    For s = 1 To 15625
                        If Wrd$(scen$(s), 7) <> "X" Then ' scen s still in running
                            If Wrd$(scen$(s), 1) <> H$ Then
                                If Wrd$(scen$(s), item) = first$(item) Then scen$(s) = scen$(s) + " X": Flag$ = "Change" ' signal a change
                            End If
                        End If
                    Next
                End If
            End If
        Next
    Next

    ' more 16.  They drink water in a house next to the house where they smoke Blend"
    If House&("water") Then ' water is a solution so house # is determined and Blend is a neighbor
        For s = 1 To 15625
            If Wrd$(scen$(s), 7) <> "X" Then
                If Wrd$(scen$(s), 5) = "Blend" Then
                    If Abs(House&("water") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
                End If
            End If
        Next
    End If
    If House&("Blend") Then '  Blend is a solution so house # is determined  next door water
        For s = 1 To 15625
            If Wrd$(scen$(s), 7) <> "X" Then
                If Wrd$(scen$(s), 4) = "water" Then
                    If Abs(House&("Blend") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
                End If
            End If
        Next
    End If

    ' more 12.  In a house next to the house where they have a horse, they smoke Dunhill.
    If House&("Dunhill") Then ' Dunhill is a solution so house # is determined  next door horse
        For s = 1 To 15625
            If Wrd$(scen$(s), 7) <> "X" Then
                If Wrd$(scen$(s), 6) = "horse" Then
                    If Abs(House&("Dunhill") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
                End If
            End If
        Next
    End If
    If House&("horse") Then ' horse is a solution so next door is Dunhill
        For s = 1 To 15625
            If Wrd$(scen$(s), 7) <> "X" Then
                If Wrd$(scen$(s), 5) = "Dunhill" Then
                    If Abs(House&("horse") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
                End If
            End If
        Next
    End If

    ' more 11.  The man who smokes Blend lives in the house next to the house with cats.
    If House&("Blend") Then ' Blend is a sloution so next door cats
        For s = 1 To 15625
            If Wrd$(scen$(s), 7) <> "X" Then
                If Wrd$(scen$(s), 6) = "cats" Then
                    If Abs(House&("Blend") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
                End If
            End If
        Next
    End If
    If House&("cats") Then ' cats is a solution so next door Blend
        For s = 1 To 15625
            If Wrd$(scen$(s), 7) <> "X" Then
                If Wrd$(scen$(s), 5) = "Blend" Then
                    If Abs(House&("cats") - Val(Wrd$(scen$(s), 1))) <> 1 Then scen$(s) = scen$(s) + " X": Flag$ = "Change"
                End If
            End If
        Next
    End If

End Sub

Sub Build (wordStr$) ' redo build to handle any word list in string form
    Dim As Long nW, nS, mW, w1, w2, i
    Dim w$
    nW = wCnt(wordStr$)
    nS = UBound(scen$) ' shared array we are building
    If nS = 0 Or nS = 1 Then
        mW = nW
        ReDim temp$(1 To nW) ' getting started with first list
        For w1 = 1 To nW
            temp$(w1) = Wrd$(wordStr$, w1)
        Next
    Else
        mW = nS * nW
        ReDim temp$(1 To nS * nW)
        For w2 = 1 To nW
            w$ = Wrd$(wordStr$, w2)
            For w1 = 1 To nS
                i = i + 1
                temp$(i) = w$ + " " + scen$(w1)
            Next
        Next
    End If
    ReDim scen$(1 To mW) 'rewrite scen$
    For i = 1 To mW
        scen$(i) = temp$(i)
    Next
End Sub

Sub showScen ' the scenarios not eliminated
    Dim As Long i, c
    For i = 1 To 15625
        If Wrd$(scen$(i), 7) <> "X" Then c = c + 1: Print c, scen$(i)
    Next
End Sub

' This duplicates JB word(string, wordNumber) base 1, space as default delimiter
' by returning the Nth word of source string s
' this function assumes s has been through wPrep
Function Wrd$ (ss$, wNumber)
    Dim s$, w$
    Dim As Long c, i
    's$ = wPrep(ss$)
    s$ = ss$ 'don't change ss$
    If Len(s$) = 0 Then Wrd$ = "": Exit Function
    w$ = "": c = 1
    For i = 1 To Len(s$)
        If Mid$(s$, i, 1) = " " Then
            If c = wNumber Then Wrd$ = w$: Exit Function
            w$ = "": c = c + 1
        Else
            w$ = w$ + Mid$(s$, i, 1)
        End If
    Next
    If c <> wNumber Then Wrd$ = " " Else Wrd$ = w$
End Function

Function wCnt (s$)
    Dim c As Integer, p As Integer, ip As Integer
    's = wPrep(s)
    If Len(s$) = 0 Then wCnt = 0: Exit Function
    c = 1: p = 1: ip = InStr(p, s$, " ")
    While ip
        c = c + 1: p = ip + 1: ip = InStr(p, s$, " ")
    Wend
    wCnt = c
End Function


RE: Rosetta Code Challenges - CharlieJV - 11-05-2022

(11-05-2022, 04:57 AM)bplus Wrote:
Zebra Puzzle 2 Sweep

Very cool. I tip my hat to you, sir.

RE: Rosetta Code Challenges - bplus - 11-05-2022

Thanks Charlie, a man with a mission!

RE: Rosetta Code Challenges - bplus - 09-10-2023

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=opera&q=25+horse+problem&sourceid=opera&ie=UTF-8&oe=UTF-8#fpstate=ive&vld=cid:4e94e9f1,vid:i-xqRDwpilM,st:0

Code: (Select All)


_Title "25 Horses" ' b+ 2022-09-06 revisit 2023-09-09



'ref

' https://www.google.com/search?client=opera&q=25+horse+problem&sourceid=opera&ie=UTF-8&oe=UTF-8#fpstate=ive&vld=cid:4e94e9f1,vid:i-xqRDwpilM,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 Smile 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.

RE: Rosetta Code Challenges - bplus - 04-29-2024

Anagrams Challenge

This thread got me wondering if i could get a better time on the Rosetta Code Anagrams Puzzle.
https://qb64phoenix.com/forum/showthread.php?tid=2620

You can see Steve and my submissions from 7 years ago, 7 years! yikes
https://rosettacode.org/wiki/Anagrams#QB64

ok so Anagrams v7 runs .0585 ave in 100 loops, and todays version runs .0536 ave in 100 loops.
wu hoo almost .005 secs improved in 7 years.

but the code looks better Smile
Code: (Select All)
$Checking:Off
' Warning: Keep the above line commented out until you know your newly edited code works.
'          You can NOT stop a program in mid run (using top right x button) with checkng off.
'
Option _Explicit
_Title "Rosetta Code Anagrams: mod #8 by bplus 2024-04-28" ' 7 years later
' anagram 7 below .06 average per 100 loop
' anagram 8 takes about .005 secs off < .055 sec
Type wordData
    As String word, code
End Type
Dim Shared w(25105) As wordData '  the main array
Dim As Integer loops, test, indextop, ansciChar, ubw, wi
Dim As Integer anaCount, setCount, wordIndex, wordLength, flag
Dim t1#, buf$, wd$, analist$, b$

t1# = Timer(.001): loops = 100
For test = 1 To loops
    'reset these for multiple loop tests
    indextop = 0 'indexTop for main data array
    anaCount = 0 'anagrams count if exceed 4 for any one code
    analist$ = ""

    buf$ = _ReadFile$("unixdict.txt")
    ReDim words$(1 To 1)
    Split buf$, Chr$(10), words$()
    ubw = UBound(words$)
    wi = 1
    While wi < ubw
        wd$ = UCase$(words$(wi))
        wordLength = Len(wd$)
        If wordLength > 2 Then
            flag = 0: wordIndex = 1
            'don't code and store a word unless all letters, no digits or apostrophes
            While wordIndex <= wordLength
                ansciChar = Asc(wd$, wordIndex) - 64 ' cap letters now 65 to 90
                If 0 < ansciChar And ansciChar < 27 Then Else flag = 1: Exit While
                wordIndex = wordIndex + 1
            Wend
            If flag = 0 Then
                indextop = indextop + 1
                w(indextop).code = altAnaCode2$(wd$)
                w(indextop).word = wd$
            End If
        End If
        wi = wi + 1
    Wend
    'Sort using a recursive Quick Sort routine on the code key of wordData Type defined.
    QSort 0, indextop

    'Now find all the anagrams, word permutations, from the same word "code" that we sorted by.
    flag = 0: wi = 0
    While wi < indextop
        'Does the sorted code key match the next one on the list?
        If w(wi).code <> w(wi + 1).code Then ' not matched so stop counting and add to report
            If setCount > 4 Then ' only want the largest sets of anagrams 5 or more
                analist$ = analist$ + b$ + Chr$(10)
                anaCount = anaCount + 1
            End If
            setCount = 0: b$ = "": flag = 0
        ElseIf flag Then ' match and match flag set so just add to count and build set
            b$ = b$ + ", " + w(wi + 1).word
            setCount = setCount + 1
        Else ' no flag means first match, start counting and building a new set
            b$ = w(wi).word + ", " + w(wi + 1).word
            setCount = 2: flag = 1
        End If
        wi = wi + 1
    Wend
Next
Print "Ave time per loop ";
Print Using "#.####"; (Timer(.001) - t1#) / loops;
Print " secs."
Print "There were"; anaCount; "anagrams sets of 5 or more words:"
Print analist$

'This sub modified for wordData Type, to sort by the .code key, the w() array is SHARED
Sub QSort (Start, Finish)
    Dim As Integer i, j
    Dim x$
    i = Start: j = Finish: x$ = w(Int((i + j) / 2)).code
    While i <= j
        While w(i).code < x$: i = i + 1: Wend
        While w(j).code > x$: j = j - 1: Wend
        If i <= j Then
            Swap w(i), w(j)
            i = i + 1: j = j - 1
        End If
    Wend
    If j > Start Then QSort Start, j
    If i < Finish Then QSort i, Finish
End Sub

Function altAnaCode2$ (wrd$) ' anaCode$ converts word to an Anagram pattern
    ' are assuming wrd$ is all letters
    Dim s$
    Dim As Integer i, p
    s$ = String$(26, "0") ' string holds final counts
    For i = 1 To Len(wrd$)
        p = Asc(wrd$, i) - 64
        Asc(s$, p) = Asc(s$, p) - 47
    Next
    altAnaCode2$ = s$
End Function

Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
    Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
    curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
    dpos = InStr(curpos, SplitMeString, delim)
    Do Until dpos = 0
        loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
        arrpos = arrpos + 1
        If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
        curpos = dpos + LD
        dpos = InStr(curpos, SplitMeString, delim)
    Loop
    loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
    ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub

The file containing the words in lower case about 25,000+ attached below