137 lines
3.2 KiB
Plaintext
137 lines
3.2 KiB
Plaintext
' FB 1.05.0 Win64
|
|
|
|
Type IndexedWord
|
|
As String word
|
|
As Integer index
|
|
End Type
|
|
|
|
' selection sort, quick enough for sorting small number of letters
|
|
Sub sortWord(s As String)
|
|
Dim As Integer i, j, m, n = Len(s)
|
|
For i = 0 To n - 2
|
|
m = i
|
|
For j = i + 1 To n - 1
|
|
If s[j] < s[m] Then m = j
|
|
Next j
|
|
If m <> i Then Swap s[i], s[m]
|
|
Next i
|
|
End Sub
|
|
|
|
' selection sort, quick enough for sorting small array of IndexedWord instances by index
|
|
Sub sortIndexedWord(iw() As IndexedWord)
|
|
Dim As Integer i, j, m, n = UBound(iw)
|
|
For i = 1 To n - 1
|
|
m = i
|
|
For j = i + 1 To n
|
|
If iw(j).index < iw(m).index Then m = j
|
|
Next j
|
|
If m <> i Then Swap iw(i), iw(m)
|
|
Next i
|
|
End Sub
|
|
|
|
' quicksort for sorting whole dictionary of IndexedWord instances by sorted word
|
|
Sub quicksort(a() As IndexedWord, first As Integer, last As Integer)
|
|
Dim As Integer length = last - first + 1
|
|
If length < 2 Then Return
|
|
Dim pivot As String = a(first + length\ 2).word
|
|
Dim lft As Integer = first
|
|
Dim rgt As Integer = last
|
|
While lft <= rgt
|
|
While a(lft).word < pivot
|
|
lft +=1
|
|
Wend
|
|
While a(rgt).word > pivot
|
|
rgt -= 1
|
|
Wend
|
|
If lft <= rgt Then
|
|
Swap a(lft), a(rgt)
|
|
lft += 1
|
|
rgt -= 1
|
|
End If
|
|
Wend
|
|
quicksort(a(), first, rgt)
|
|
quicksort(a(), lft, last)
|
|
End Sub
|
|
|
|
Dim t As Double = timer
|
|
Dim As String w() '' array to hold actual words
|
|
Open "undict.txt" For Input As #1
|
|
Dim count As Integer = 0
|
|
While Not Eof(1)
|
|
count +=1
|
|
Redim Preserve w(1 To count)
|
|
Line Input #1, w(count)
|
|
Wend
|
|
Close #1
|
|
|
|
Dim As IndexedWord iw(1 To count) '' array to hold sorted words and their index into w()
|
|
Dim word As String
|
|
For i As Integer = 1 To count
|
|
word = w(i)
|
|
sortWord(word)
|
|
iw(i).word = word
|
|
iw(i).index = i
|
|
Next
|
|
quickSort iw(), 1, count '' sort the IndexedWord array by sorted word
|
|
|
|
Dim As Integer startIndex = 1, length = 1, maxLength = 1, ub = 1
|
|
Dim As Integer maxIndex(1 To ub)
|
|
maxIndex(ub) = 1
|
|
word = iw(1).word
|
|
|
|
For i As Integer = 2 To count
|
|
If word = iw(i).word Then
|
|
length += 1
|
|
Else
|
|
If length > maxLength Then
|
|
maxLength = length
|
|
Erase maxIndex
|
|
ub = 1
|
|
Redim maxIndex(1 To ub)
|
|
maxIndex(ub) = startIndex
|
|
ElseIf length = maxLength Then
|
|
ub += 1
|
|
Redim Preserve maxIndex(1 To ub)
|
|
maxIndex(ub) = startIndex
|
|
End If
|
|
startIndex = i
|
|
length = 1
|
|
word = iw(i).word
|
|
End If
|
|
Next
|
|
|
|
If length > maxLength Then
|
|
maxLength = length
|
|
Erase maxIndex
|
|
Redim maxIndex(1 To 1)
|
|
maxIndex(1) = startIndex
|
|
ElseIf length = maxLength Then
|
|
ub += 1
|
|
Redim Preserve maxIndex(1 To ub)
|
|
maxIndex(ub) = startIndex
|
|
End If
|
|
|
|
Print Str(count); " words in the dictionary"
|
|
Print "The anagram set(s) with the greatest number of words (namely"; maxLength; ") is:"
|
|
Print
|
|
Dim iws(1 To maxLength) As IndexedWord '' array to hold each anagram set
|
|
For i As Integer = 1 To UBound(maxIndex)
|
|
For j As Integer = maxIndex(i) To maxIndex(i) + maxLength - 1
|
|
iws(j - maxIndex(i) + 1) = iw(j)
|
|
Next j
|
|
sortIndexedWord iws() '' sort anagram set before displaying it
|
|
For j As Integer = 1 To maxLength
|
|
Print w(iws(j).index); " ";
|
|
Next j
|
|
Print
|
|
Next i
|
|
|
|
Print
|
|
Print "Took ";
|
|
Print Using "#.###"; timer - t;
|
|
Print " seconds on i3 @ 2.13 GHz"
|
|
|
|
Print
|
|
Print "Press any key to quit"
|
|
Sleep
|