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
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 SubThe file containing the words in lower case about 25,000+ attached below
b = b + ...