11-01-2022, 12:19 PM (This post was last modified: 11-01-2022, 12:25 PM by bplus.)
@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.
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
09-10-2023, 02:40 PM (This post was last modified: 09-10-2023, 05:14 PM by bplus.)
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
' 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.
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
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
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.