Need custom sorting algorithm - Printable Version

Code: (Select All)

Const columns = 65, rows = 21 ' this is based on OP's screen shot

DefLng A-Z

' create some data randomly for testing

Dim cols$(1 To columns) ' make cols$()

For c = 1 To columns

    For r = 1 To rows

        cols$(c) = cols$(c) + IfS$(Int(Rnd * 2), "*", "-")

    Next

Next



'display

Color 7

For m = 1 To rows

    For c = 1 To columns

        Locate m, c: Print Mid$(cols$(c), m, 1);

    Next

Next

'        count matches and watch a color show!

' matches

Dim matches(1 To columns)

For i = 1 To columns - 1

    For j = i + 1 To columns

        match = 0

        For r = 1 To rows

            If Asc(cols$(i), r) = Asc(cols$(j), r) Then

                matches(i) = matches(i) + 1: matches(j) = matches(j) + 1

                Color 14

                Locate r, i: Print Mid$(cols$(i), r, 1);

                Locate r, j: Print Mid$(cols$(j), r, 1);

            Else

                Color 9

                Locate r, i: Print Mid$(cols$(i), r, 1);

                Locate r, j: Print Mid$(cols$(j), r, 1);

            End If

        Next

        _Delay .1

        Color 7

        For m = 1 To rows

            For c = 1 To columns

                Locate m, c: Print Mid$(cols$(c), m, 1);

            Next

        Next

    Next

Next



Color 15

Cls

Dim Shared IDX(1 To columns) ' swap ID when swap values

For i = 1 To columns

    IDX(i) = i

Next

QuickSort 1, columns, matches()

Open "Matches column ID.txt" For Output As #1

For i = 1 To columns

    If i < 21 Then

        c = 0

    ElseIf i < 41 Then

        c = 1

    ElseIf i < 61 Then

        c = 2

    Else

        c = 3

    End If

    If i Mod 20 = 0 Then c = c + 1

    Locate (i Mod 20) + 1, c * 20 + 1

    Print matches(i); IDX(i);

    Print #1, matches(i); IDX(i)

Next

Close #1

Locate 22, 1: Print





Sub QuickSort (start As Long, finish As Long, array() As Long)

    Dim Hi As Long, Lo As Long, Middle As Single

    Hi = finish: Lo = start

    Middle = array((Lo + Hi) / 2) 'find middle of array

    Do

        Do While array(Lo) < Middle: Lo = Lo + 1: Loop

        Do While array(Hi) > Middle: Hi = Hi - 1: Loop

        If Lo <= Hi Then

            Swap array(Lo), array(Hi)

            Swap IDX(Lo), IDX(Hi) ' track the IDX of the matches

            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



Function IfS$ (Bool&, tru$, fals$) ' IF Boolean Return True$ else False$

    If Bool& Then IfS$ = tru$ Else IfS$ = fals$

End Function

Code: (Select All)