' 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