04-27-2024, 09:34 PM
And now that @bplus has taken time to take a breath, I present to you guys the STEVECODE(tm)!!!
Code: (Select All)
Option _Explicit
_Title "anaCode3$ versus peteCode3$ with STEVE the winner" ' b+ 2024-04-26 speed test, which Steve obviously wins. 
' anaCode$ returned to original format of len = 26 letter counts but improved?
' this is most useful to use with games using letters from words
' anacode3$ is to compare apples to apples in the function return format
' aha, i cracked petecode2() time!
Dim a$(25000), p$(25000), s$(25000)
'''' check i made modifications correctly
'Dim test$(9)
'Dim As Integer i
'test$(0) = "grmaana"
'test$(1) = "angiogram"
'test$(2) = "naagrma"
'test$(3) = "telgram"
'test$(4) = "gramana"
'test$(5) = "gram"
'test$(6) = "nag"
'test$(7) = "tag"
'test$(8) = "am"
'test$(9) = "grip"
'For i = 0 To 9
' Print test$(i), petecode2$(test$(i)), petecode3$(test$(i))
'Next
'End
'''' ok looks right
Dim i As Integer, j As Integer
Dim start#, w$, ana2Time#, peteTime#, anatime#, pete3time#, steveTime#
start# = Timer(.001)
For i = 1 To 25
j = 0
Open "WORDS.txt" For Input As #1
While Not EOF(1)
Input #1, w$
j = j + 1
p$(j) = petecode2$(w$)
Wend
Close
Next
peteTime# = Timer(.001) - start#
start# = Timer(.001)
For i = 1 To 25
j = 0
Open "WORDS.txt" For Input As #1
While Not EOF(1)
Input #1, w$
j = j + 1
p$(j) = petecode3$(w$)
Wend
Close
Next
pete3time# = Timer(.001) - start#
start# = Timer(.001)
For i = 1 To 25
j = 0
Open "WORDS.txt" For Input As #1
While Not EOF(1)
Input #1, w$
j = j + 1
a$(j) = altAnaCode$(w$)
Wend
Close
Next
anatime# = Timer(.001) - start#
start# = Timer(.001)
For i = 1 To 25
j = 0
Open "WORDS.txt" For Input As #1
While Not EOF(1)
Input #1, w$
j = j + 1
a$(j) = AnaCode3$(w$)
Wend
Close
Next
ana2Time# = Timer(.001) - start#
start# = Timer(.001)
For i = 1 To 25
j = 0
Open "WORDS.txt" For Binary As #1
While Not EOF(1)
Line Input #1, w$
j = j + 1
s$(j) = SteveCode$(w$)
Wend
Close
Next
steveTime# = Timer(.001) - start#
Print "Anacode3 Time ="; ana2Time#, "PeteCode3 Time ="; pete3time#
Print "altAnaCode$ time ="; anatime#, "PeteCode2 Time ="; peteTime#
Print "steveCode$ Time ="; steveTime#
Print "DIFF CHECK anaCcode3 versus PeteCode3"
For i = 1 To j ' checking for differences between array values
If a$(i) <> p$(i) Then Print a$(i), p$(i)
If a$(i) <> s$(i) Then Print a$(i), s$(i)
Next
Print "END OF DIFF CHECK"
Print: Print " Check tail end of arrays:"
For i = j - 15 To j
Print a$(i), p$(i), s$(i)
Next
Function SteveCode$ (wrd$)
Static t As String * 30
Dim As Long i, seed, j, l
l = Len(wrd$)
For i = 65 To 90
seed = InStr(seed, wrd$, Chr$(i))
While seed
j = j + 1
Asc(t, j) = i
seed = InStr(seed + 1, wrd$, Chr$(i))
Wend
If seed >= l Then Exit For
Next
SteveCode$ = Left$(t, l)
End Function
' back to original form of anacode using counts of each letter 1 to 26
' this limits numbers of repeated letters to 9 max
' this code also assumes all letters but need not be assumed capitals
Function AnaCode$ (wrd$) ' anaCode$ converts word to an Anagram pattern
' are assuming wrd$ is all letters
Dim s$, w$
Dim As Integer i, p
s$ = String$(26, "0") ' number of A's in first, number of B's in 2nd, number of C's in third
w$ = UCase$(wrd$) ' don't assume all caps as expected
For i = 1 To Len(wrd$)
p = Asc(w$, i) - 64 ' A=1, B=2...
Mid$(s$, p, 1) = _Trim$(Str$(Asc(s$, p) - 47)) ' finally!! better
Next
AnaCode$ = s$
End Function
Function altAnaCode$ (wrd$) ' anaCode$ converts word to an Anagram pattern
Dim As Integer L(65 To 90), i, p
Dim t$(65 To 90), w$
w$ = UCase$(wrd$) ' don't assume all caps as expected
For i = 1 To Len(w$)
p = Asc(w$, i) ' A=1, B=2...
L(p) = L(p) + 1
Next
For i = 65 To 90
t$(i) = LTrim$(Str$(L(i)))
Next
altAnaCode$ = bind$(t$())
End Function
' return sorted anagram code string for any word, call ucase$(wrd$) for all caps
Function AnaCode2$ (wrd$) ' anaCode$ converts word to an Anagram pattern
' wrd$ is assumed to be in all capitals!!!
' number of A's in first, number of B's in 2nd, number of C's in third
Dim As Integer L(65 To 90), i, p
Dim rtn$, w$
w$ = UCase$(wrd$) ' don't assume all caps as expected
For i = 1 To Len(w$)
p = Asc(w$, i) ' A=1, B=2...
L(p) = L(p) + 1
Next
For i = 65 To 90
If L(i) Then rtn$ = rtn$ + String$(L(i), i)
Next
AnaCode2$ = rtn$
End Function
Function AnaCode3$ (wrd$) ' anaCode$ converts word to an Anagram pattern
' wrd$ is assumed to be in all capitals!!!
' number of A's in first, number of B's in 2nd, number of C's in third
Dim As Integer L(65 To 90), i, p
Dim w$
w$ = UCase$(wrd$) ' don't assume all caps as expected
For i = 1 To Len(w$)
p = Asc(w$, i) ' A=1, B=2...
L(p) = L(p) + 1
Next
Dim t$(65 To 90)
For i = 65 To 90
If L(i) Then t$(i) = String$(L(i), i)
Next
AnaCode3$ = bind$(t$())
End Function
Function petecode2$ (la$)
Dim rtn$, i%, seed%, j%, a$
a$ = UCase$(la$)
rtn$ = Space$(Len(a$))
For i% = 65 To 90
seed% = InStr(a$, Chr$(i%))
While seed%
j% = j% + 1
Mid$(rtn$, j%) = Chr$(i%)
seed% = InStr(seed% + 1, a$, Chr$(i%))
Wend
Next
petecode2$ = _Trim$(rtn$)
End Function
Function petecode3$ (la$)
Dim i%, seed%, j%, a$
Dim t$(1 To Len(la$))
a$ = UCase$(la$)
For i% = 65 To 90
seed% = InStr(a$, Chr$(i%))
While seed%
j% = j% + 1
t$(j%) = Chr$(i%)
seed% = InStr(seed% + 1, a$, Chr$(i%))
Wend
Next
petecode3$ = bind$(t$())
End Function
Function bind$ (arr$())
Dim As Long lb, ub, i, size, p
Dim rtn$
lb = LBound(arr$)
ub = UBound(arr$)
For i = lb To ub
size = size + Len(arr$(i))
Next
rtn$ = Space$(size)
p = 1
For i = lb To ub
Mid$(rtn$, p) = arr$(i)
p = p + Len(arr$(i))
Next
bind$ = rtn$
End Function