Sort Challenge

[John Davidson]

Post your entries to the Sort Challenge here.

[Rod]

I'm not absolutely sure what kind of sort this is, extraction? I find the lowest record in a pool of ever reducing records and build up the sorted file.

Nice distraction, thank you for hosting the challenge. All other projects delayed yet again

Code: Select all

'Sort challenge for Just Basic April 2005
'Entry by Rod Bird
'
'Useage - call function with comma delimited file name and column sort order string.
'Any comma delimited file can be sorted on as many columns as exist, in any order.
'i.e. "1"=sort on column 1. "14"=sort on column 1 followed by column 4

time=SortFile("SortFile.dat","1")
print "Sorted file in ";time;" seconds."
wait

function SortFile(f$,order$)

'if there is no order default to col one
    if order$="" then order$="1"
    open f$ for input as #Inp

'get the number of lines in the file
    print "Opening file."
    record=0
    while eof(#Inp) = 0
        line input #Inp, nextRecord$
        record=record+1
    wend

'get the number of fields in the file
    entry=1
    nextEntry$=word$(nextRecord$,entry,",")
    while nextEntry$<>""
        entry=entry+1
        nextEntry$=word$(nextRecord$,entry,",")
    wend
    entry=entry-1
    close #Inp

'now dimension a temp array and read in the file
    open f$ for input as #Inp
    dim temparray$(record,entry)
    for r = 1 to record
        line input #Inp, nextRecord$
        for e = 1 to entry
            temparray$(r,e)=word$(nextRecord$,e,",")
        next e
    next r
    close #Inp

'now sort the file according to the column order requested.
'we put the lowest record found at the top of the file.
'we then find the lowest record in the remaining records and
'put that next top etc etc.
    print "Sorting file."
    time=time$("ms")
    for r = 1 to record
        'create the compare string
        compa$=""
        for p=1 to len(order$)
            compa$=compa$+temparray$(r,val(mid$(order$,p,1)))
        next p
        lowest=0
        for s = r+1 to record
            'create the string to compare against
            compb$=""
            for p=1 to len(order$)
                compb$=compb$+temparray$(s,val(mid$(order$,p,1)))
            next p
            'if it is lower then swap to remember the lowest record found
            if compa$>compb$ then
                compa$=compb$
                lowest=s
            end if
        next s
        'if we found a lower record put it to the current building record position
        if lowest>0 then
        for e = 1 to entry
            swaparray$(e)=temparray$(r,e)
        next e
        for e = 1 to entry
            temparray$(r,e)=temparray$(lowest,e)
        next e
        for e = 1 to entry
            temparray$(lowest,e)=swaparray$(e)
        next e
        end if
    next r
    SortFile=(time$("ms")-time)/1000
    'print out sorted file for info
    for r = 1 to record
        for e = 1 to entry
            print temparray$(r,e);",";
        next e
    print
    next r
end function

[Dennis]

Here's my entry.

[JanetTerra]

Nice GUI, Dennis! Okay, here's my submission. No frills and no better than the others.

Code: Select all

' NL Contents sorter
' File Layout
' NL# , Title , Author , Version
' Contest Entry by Janet Terra

    Nomainwin
    lineCount = 0

'Count the number of items
    Open "SortTest.dat" for Input as #1
        While not(eof(#1))
            Line Input #1,dummy$
            lineCount = lineCount + 1
        Wend
    Close #1

'Dim nlLine$(lineCount), nlArray$(lineCount)
    Dim nlLine$(lineCount)
    Dim nlArray$(lineCount)

'Read the nlLine$()
    Open "SortTest.dat" for input as #1
        For i = 1 to lineCount
            Line Input #1, nlLine$(i)
        Next i
    Close #1

    WindowWidth = 790
    WindowHeight = 580

    Texteditor #main.te, 1, 1, 780, 482
    Menu #main, "Sort &Options", "Sort by &Newsletter", _
        [SortByNewsletter], "Sort by &Title", [SortByTitle], _
        "Sort by &Author", [SortByAuthor], "Sort by &Compatibility", _
        [SortByCompatibility],|, "E&xit", [endProgram]
    Menu #main, "&Save", "&Save This File", [SaveThisFile]
    Open "Just BASIC Sort Challenge - JLT" for Window as #main
    #main, "Trapclose [endProgram]"
    #main, "Font Courier_New 10 Bold"

[SortByNewsletter]
    startTime = Time$("ms")
    Call SortMessage "Newsletter Issue"
    Call StoreArray lineCount, 1, 2, 3, 4
    ShakerStringSort = ShakerStringSort(lineCount)
    durationTime = Time$("ms") - startTime
    Call ShowArray lineCount
    Call ShowTime lineCount, durationTime
    Wait

[SortByTitle]
    startTime = Time$("ms")
    Call SortMessage "Newsletter Title"
    Call StoreArray lineCount, 2, 3, 1, 4
    ShakerStringSort = ShakerStringSort(lineCount)
    durationTime = Time$("ms") - startTime
    Call ShowArray lineCount
    Call ShowTime lineCount, durationTime
    Wait

[SortByAuthor]
    startTime = Time$("ms")
    Call SortMessage "Newsletter Author"
    Call StoreArray lineCount, 3, 2, 1, 4
    ShakerStringSort = ShakerStringSort(lineCount)
    durationTime = Time$("ms") - startTime
    Call ShowArray lineCount
    Call ShowTime lineCount, durationTime
    Wait

[SortByCompatibility]
    startTime = Time$("ms")
    Call SortMessage "JB Compatibility"
    Call StoreArray lineCount, 4, 1, 2, 3
    ShakerStringSort = ShakerStringSort(lineCount)
    durationTime = Time$("ms") - startTime
    Call ShowArray lineCount
    Call ShowTime lineCount, durationTime
    Wait

[SaveThisFile]
    #main.te, "!Contents text$"
    Open "titleContents.dat" for Output as #1
    Print #1, text$
    Close #1

    Wait

[endProgram]
    Close #main
    End

    Function ShakerStringSort(nItems)
        ThisItem = 1 : CompareItems = nItems
        #main.te, Space$(12);
        While ThisItem < CompareItems
            min = ThisItem
            max = ThisItem

            For pass = ThisItem + 1 To CompareItems
                If nlArray$(pass) < nlArray$(min) Then min = pass
                If nlArray$(pass) > nlArray$(max) Then max = pass
            Next pass

            nlArray$(0) = nlArray$(min)
            nlArray$(min) = nlArray$(ThisItem)
            nlArray$(ThisItem) = nlArray$(0)

            If max = ThisItem Then
                nlArray$(0) = nlArray$(min)
                nlArray$(min) = nlArray$(CompareItems)
                nlArray$(CompareItems) = nlArray$(0)
            Else
                nlArray$(0) = nlArray$(max)
                nlArray$(max) = nlArray$(CompareItems)
                nlArray$(CompareItems) = nlArray$(0)
            End If

            ThisItem = ThisItem + 1
            CompareItems = CompareItems - 1
            If (ThisItem/20) = Int(ThisItem/20) Then
                #main.te, ".";
            End If
        Wend
        #main.te, ""
        nlArray$(0) = ""
    End Function

    Sub StoreArray lineCount, F1, F2, F3, F4
        Redim nlArray$(lineCount)
        For i = 1 to lineCount
            nlArray$(i) = Word$(nlLine$(i), F1, ",");"," + Word$(nlLine$(i), F2, ",");"," + _
                Word$(nlLine$(i), F3, ",");"," + Word$(nlLine$(i), F4, ",")
        Next i
    End Sub

    Sub SortMessage SortField$
        Redim nlArray$(0)
        #main.te, "!Cls"
        For i = 1 to 10
            #main.te, ""
        Next i
        #main.te, Space$(12);"SORTing by ";SortField$
    End Sub

    Sub ShowArray lineCount
        #main.te, "!Cls"
        #main.te, "There were ";lineCount;" values read from the file."
        #main.te, ""
        For i = 1 to lineCount
            #main.te, nlArray$(i)
        Next i
    End Sub

    Sub ShowTime lineCount, durationTime
        #main.te, ""
        #main.te, "The array of ";lineCount;" items was sorted in ";durationTime;" milliseconds."
    End Sub

[jeanroule]

Hello,
here is my entry. It was a rush against time as it is allready 16th of April where I am ! (ok I am 9 minutes late)

So it could have been better. I am not really happy with code, but it does the job !

Cheers
Joris

Code: Select all

'April 2005 JustBasic SortChallenge
'Entry by Joris Van den Bossche aka JeanRoule


[VAR]

    NrOfLines = 0
    fileName$ =""
    SaveName$ =""
    Choice    = 0

[MAIN]
    GOSUB [openmywindow]
    WAIT
    'we go eventdriven

    'user can click
    '==>OPEN in order to open the sortfile
    '==>the numbers 1 2 3 4   in order to select on what element to sort
    '==>SAVE in order to save the sorted file

END 'of MAIN


'***** BRANCHES *****

[quicksort]
    startTime = time$("milliseconds")   'clock starts ticking
    GOSUB [assignarray]                 'please note that array assignment is
                                        'INSIDE time measurement

    dummy=QuickSort(1,NrOfLines)        'Core of the program

    endTime=time$("milliseconds")       'stop the clock, print the time
    print #brd.t1, endTime-startTime; " milliseconds for sorting"
    WAIT

[dimensioning]
    DIM ID$(NrOfLines)
    DIM Title$(NrOfLines)
    DIM Author$(NrOfLines)
    DIM Stock$(NrOfLines)
    DIM Array$(NrOfLines)
    'Array$() is the array I will actually sort on.

RETURN

[readdata]
    OPEN fileName$ FOR INPUT AS #fh
    i = 1
    WHILE eof(#fh) = 0
        INPUT #fh, ID$(i), Title$(i), Author$(i), Stock$(i)
        i = i+1
    WEND
    CLOSE #fh
RETURN

[assignarray]
    'assign the elements we will sort on
    SELECT CASE Choice
    CASE 1
        FOR x = 1 TO NrOfLines
            Array$(x) = ID$(x)
        NEXT x
    CASE 2
        FOR x = 1 TO NrOfLines
            Array$(x) = Title$(x)
        NEXT x
    CASE 3
        FOR x = 1 TO NrOfLines
            Array$(x) = Author$(x)
        NEXT x
    CASE 4
        FOR x = 1 TO NrOfLines
            Array$(x) = Stock$(x)
        NEXT x
    CASE ELSE
END SELECT

RETURN

[output]
    IF Choice = 0 THEN
        NOTICE "First sort a file..."
        WAIT
    END IF
    IF SaveFile("Save sorted file as...", "*.dat", SaveName$) THEN
        OPEN SaveName$ FOR OUTPUT AS #fh
        FOR i = 1 to NrOfLines
            PRINT #fh, ID$(i);" ";Title$(i);" ";Author$(i);" ";Stock$(i)
        NEXT i
        CLOSE #fh
    ELSE
        WAIT
    END IF
WAIT

[openmywindow]
    nomainwin
    WindowWidth = 240
    WindowHeight = 180
    UpperleftX = 50
    UpperleftY = 50

    button #brd, " Open ", [go],     UL,  10, 60
    button #brd, " Save ", [output], UL, 70 , 60
    button #brd, " 1 ", [1], UL,  10, 100
    button #brd, " 2 ", [2], UL,  40, 100
    button #brd, " 3 ", [3], UL,  70, 100
    button #brd, " 4 ", [4], UL, 100, 100

    textbox #brd.t1, 10, 10, 210, 25

    open "joriSort" for graphics_nsb as #brd

    print #brd, "trapclose [quit]";
    print #brd.t1, "Please OPEN a file"
RETURN

[go]
    IF OpenFile("Open the Sort File","*.dat",fileName$) THEN
        NrOfLines = NrOfLines(fileName$)
        GOSUB [dimensioning]
        GOSUB [readdata]
        print #brd.t1, "Select on what element to sort"
        WAIT
    ELSE
        NOTICE "No file selected, terminating"
        GOSUB [quit]
    END IF
RETURN

[quit]
    CLOSE #brd
END

[1]
    IF NrOfLines = 0 THEN
        NOTICE "First open a file..."
        WAIT
    ELSE
        PRINT #brd.t1, "Sorting on 1..."
        Choice = 1:GOTO [quicksort]
    END IF
[2]
   IF NrOfLines = 0 THEN
        NOTICE "First open a file...":WAIT
   ELSE
        PRINT #brd.t1, "Sorting on 2..."
        Choice = 2:GOTO [quicksort]
   END IF
[3]
   IF NrOfLines = 0 THEN
        NOTICE "First open a file...":WAIT
   ELSE
        PRINT #brd.t1, "Sorting on 3..."
        Choice = 3:GOTO [quicksort]
   END IF
[4]
   IF NrOfLines = 0 THEN
        NOTICE "First open a file...":WAIT
   ELSE
    PRINT #brd.t1, "Sorting on 4..."
    Choice = 4:GOTO [quicksort]
   END IF

'**** FUNCTIONS ****

FUNCTION QuickSort(Left,Right)

   'Recursive Qsort. Alledgedly slower than an iterative one, but so much prettier !

   dummyLeft=Left
   dummyRight=Right
   pivot$ = Array$(Left)    'take the first element as pivot

   WHILE (dummyLeft <= dummyRight)
      WHILE (Array$(dummyLeft) < pivot$ AND dummyLeft < Right)
         dummyLeft = dummyLeft + 1
      WEND
      WHILE (pivot$ < Array$(dummyRight) AND dummyRight > Left)
         dummyRight = dummyRight - 1
      WEND

      IF (dummyLeft <= dummyRight) THEN
         S1$ = Array$(dummyLeft)                                'Copying ALL the the data-elements
         S2$ = ID$(dummyLeft)                                   'It took me 2 days to find this
         S3$ = Title$(dummyLeft)
         S4$ = Author$(dummyLeft)                               'I roughly estimate the penalty for all this code
         S5$ = Stock$(dummyLeft)                                'within the Qsort to 50 milliseconds

         Array$(dummyLeft)  = Array$(dummyRight)
         ID$(dummyLeft)     = ID$(dummyRight)
         Title$(dummyLeft)  = Title$(dummyRight)
         Author$(dummyLeft) = Author$(dummyRight)
         Stock$(dummyLeft)  = Stock$(dummyRight)

         Array$(dummyRight) = S1$
         ID$(dummyRight)    = S2$
         Title$(dummyRight) = S3$
         Author$(dummyRight)= S4$
         Stock$(dummyRight) = S5$

         dummyLeft = dummyLeft + 1
         dummyRight = dummyRight - 1
      END IF
   WEND

   IF (Left < dummyRight) THEN
        dummy = QuickSort(Left, dummyRight)
   END IF

   IF (dummyLeft < Right) THEN
        dummy = QuickSort(dummyLeft, Right)
   END IF

END FUNCTION

FUNCTION NrOfLines(File$)
    NrOfLines = 0
    OPEN File$ FOR INPUT AS #fh
    WHILE eof(#fh) = 0
        INPUT #fh, One$, Two$, Three$, Four$    'Dummy Values
        NrOfLines = NrOfLines +1
    WEND
    CLOSE #fh
END FUNCTION


FUNCTION OpenFile(Title$, joker$, byref file$)

    OpenFile = 0    'BOOLEAN FALSE as we have no file yet
    FILEDIALOG Title$, joker$, file$

    IF file$<>"" THEN
        OpenFile = 1    'BOOLEAN TRUE as we have a file
    ELSE
        OpenFile = 0
    END IF

END FUNCTION


FUNCTION SaveFile(Title$, joker$, byref file$)

    SaveFile = 0    'BOOLEAN FALSE as we have no file yet
    FILEDIALOG Title$, joker$, file$

    IF file$<>"" THEN
        SaveFile = 1    'BOOLEAN TRUE as we have a file
    ELSE
        SaveFile = 0
    END IF

END FUNCTION

[JanetTerra]

This .dat file is an updated of the original sort.dat file used for the sorting challenge. In this file, the 4th field (JB Compatibility) has been updated for Issues 1-8 and 93 - 131. All other issues have -1 (unclassified) in the 4th field. The key is
0 - Informational only, no code
1 - Just BASIC compatible as is
2 - Just BASIC compatible with minor modifications
3 - Not Just BASIC compatible