Login

SBM Productions · 03-25-2005, 05:31 AM

Yeah I'd like to have a look at the modified version of sortdemo.bas . My email is theshashiman@gmail.com
Its actually the first time I've heard of this program.

na_th_an · 03-25-2005, 07:29 AM

Â¿This sortdemo.bas?

It's a true hyeroglyph Big Grin

Code:
REM SAVE SORTDEMO

REM ++++++++++++++++++++++++++++++

REM + DEMONSTRATION AV SORTERING +

REM ++++++++++++++++++++++++++++++

REM + Version 1.0 83-03-20       +

REM + Konstr. Arne Sp}ngtorp     +

REM + <1218>^

REM +         632 30  E-tuna     +

REM +         016/42 45 04       +

REM ++++++++++++++++++++++++++++++

REM 

REM Initiering

REM 

DIM V$(22%),V%(10%),A%(10%)

RANDOMIZE 

DEFFNT%=(ABS(U%)>9%)

DATA 31882,32138,32394,32650,31922,32178,32434,32690,31962,32218

FOR A%=1% TO 10% : READ A%(A%) : NEXT A%

V$(0%)='     +---+'

V$(1%)='V(1) !   !'

V$(2%)='     +---+'

V$(3%)='V(2) !   !'

V$(4%)='     +---+'

V$(5%)='V(3) !   !'

V$(6%)='     +---+'

V$(7%)='V(4) !   !'

V$(8%)='     +---+'

V$(9%)='V(5) !   !'

V$(10%)='     +---+'

V$(11%)='V(6) !   !'

V$(12%)='     +---+'

V$(13%)='V(7) !   !'

V$(14%)='     +---+'

V$(15%)='V(8) !   !'

V$(16%)='     +---+'

V$(17%)='V(9) !   !'

V$(18%)='     +---+'

V$(19%)='V(10)!   !'

V$(20%)='     +---+'

V$(21%)='H    !   !'

V$(22%)='     +---+'

P1$(1%)='10 REM SORTERING AV TAL'

P1$(2%)='11 REM V(10) SORTVEKTOR'

P1$(3%)='12 REM H  HJ[LPVARIABEL'

P1$(4%)='13 DIM V(10)'

P1$(5%)='14 H=0'

P1$(6%)='15 FOR I=1 TO 10'

P1$(7%)='16 V(I)=99-INT(RND*199)'

P1$(8%)='17 NEXT I'

P2$(1%)='20 FOR I=1 TO 9    <---+'

P2$(2%)='21 FOR J=I+1 TO 10 <-+ !'

P2$(3%)='22 IF V(I)>V(J)      ! !'

P2$(4%)='      THEN H   =V(I) ! !'

P2$(5%)='           V(I)=V(J) ! !'

P2$(6%)='           V(J)=H    ! !'

P2$(7%)='23 NEXT J          <-+ !'

P2$(8%)='24 NEXT I          <---+'

REM 

REM Prog-init

REM 

; CHR$(12%)

; 'Detta {r' : ; 

; 'ett pro-' : ; 

; 'gram f|r' : ; 

; 'demonstra-' : ; 

; 'tion av en' : ; 

; 'SORTERING!' : ; 

FOR X%=1% TO 8%

; CUR(X%,16%)P1$(X%)

NEXT X%

FOR X%=1% TO 8%

; CUR(X%+8%,16%)P2$(X%)

NEXT X%

; CUR(20%,16%)'>> Tryck n}gon tangent'

; CUR(21%,16%)'   f|r forts{ttning!';

GET G$

FOR X%=1% TO 16%

; CUR(X%,16%)STRING$(24%,32%)

NEXT X%

FOR X%=0% TO 22%

; CUR(X%,15%)'!' : NEXT X%

FOR X%=1% TO 8%

; CUR(X%*2%-1%,16%)P1$(X%)

NEXT X%

; CUR(21%,36%); : GET G$

REM 

REM Rita vektor

REM 

FOR X%=0% TO 22%

; CUR(X%,0%)V$(X%)

NEXT X%

; CUR(21%,36%); : GET G$

REM 

REM Slumptal

REM 

FOR X%=1% TO 10%

V%(X%)=99%-INT(RND*199%)

U%=V%(X%)

; CUR(X%*2%-1%,7%+FNT%)U%

NEXT X%

; CUR(21%,7%)0%

; CUR(21%,36%); : GET G$

REM 

REM Prog-sort

REM 

FOR X%=1% TO 8%

; CUR(X%*2%-1%,16%)P2$(X%)

NEXT X%

; CUR(21%,36%); : GET G$

REM 

REM Sortering

REM 

FOR I%=1% TO 9%

FOR A%=31891% TO 31902%

POKE A%,PEEK(A%) OR 128% : NEXT A%

GET G$ : FOR A%=31891% TO 31902%

POKE A%,PEEK(A%) AND 127% : NEXT A%

FOR A%=32699% TO 32704%

POKE A%,PEEK(A%) AND 127% : NEXT A%

IF I%=I0% 1320

; CUR(I0%*2%-1%,10%)' '

POKE A%(I%),PEEK(A%(I%)) AND 127%

; CUR(I%*2%-1%,10%)'I'; : I0%=I%

POKE A%(I%),PEEK(A%(I%)) OR 128%

FOR J%=I%+1% TO 10%

FOR A%=32147% TO 32161%

POKE A%,PEEK(A%) OR 128% : NEXT A%

GET G$ : FOR A%=32147% TO 32161%

POKE A%,PEEK(A%) AND 127% : NEXT A%

FOR A%=32443% TO 32448%

POKE A%,PEEK(A%) AND 127% : NEXT A%

IF J%=J0% 1440

; CUR(J0%*2%-1%,10%)' '

POKE A%(J%),PEEK(A%(J%)) AND 127%

; CUR(J%*2%-1%,10%)'J'; : J0%=J%

POKE A%(J%),PEEK(A%(J%)) OR 128%

FOR A%=32403% TO 32414%

POKE A%,PEEK(A%) OR 128% : NEXT A%

GET G$ : FOR A%=32403% TO 32414%

POKE A%,PEEK(A%) AND 127% : NEXT A%

IF V%(I%)>V%(J%) 1510 ELSE 1860

H%=V%(I%)

FOR A%=32662% TO 32675%

POKE A%,PEEK(A%) OR 128% : NEXT A%

U%=H% : FOR R%=I%*2%-1% TO 21%

; CUR(R%,12%+FNT%)U%;

GET G$

; CUR(R%,11%)'   '; : NEXT R%

; CUR(21%,6%)'   ';

; CUR(21%,7%+FNT%)U%;

GET G$ : FOR A%=32662% TO 32675%

POKE A%,PEEK(A%) AND 127% : NEXT A%

FOR A%=31939% TO 31947%

POKE A%,PEEK(A%) OR 128% : NEXT A%

V%(I%)=V%(J%)

U%=V%(J%)

FOR R%=J%*2%-1% TO I%*2%-1% STEP -1%

; CUR(R%,12%+FNT%)U%;

GET G$

; CUR(R%,11%)'   '; : NEXT R%

; CUR(I%*2%-1%,6%)'   ';

; CUR(I%*2%-1%,7%+FNT%)U%;

GET G$ : FOR A%=31939% TO 31947%

POKE A%,PEEK(A%) AND 127% : NEXT A%

V%(J%)=H%

FOR A%=32195% TO 32200%

POKE A%,PEEK(A%) OR 128% : NEXT A%

U%=H%

FOR R%=21% TO J%*2%-1% STEP -1%

; CUR(R%,12%+FNT%)U%;

GET G$

; CUR(R%,11%)'   '; : NEXT R%

; CUR(J%*2%-1%,6%)'   ';

; CUR(J%*2%-1%,7%+FNT%)U%;

GET G$ : FOR A%=32195% TO 32200%

POKE A%,PEEK(A%) AND 127% : NEXT A%

FOR A%=32443% TO 32448%

POKE A%,PEEK(A%) OR 128% : NEXT A%

FOR A%=32147% TO 32161%

POKE A%,PEEK(A%) OR 128% : NEXT A%

NEXT J%

FOR A%=32699% TO 32704%

POKE A%,PEEK(A%) OR 128% : NEXT A%

NEXT I%

FOR A%=32443% TO 32448%

POKE A%,PEEK(A%) AND 127% : NEXT A%

FOR A%=32699% TO 32704%

POKE A%,PEEK(A%) AND 127% : NEXT A%

FOR A%=32147% TO 32161%

POKE A%,PEEK(A%) AND 127% : NEXT A%

POKE A%(9%),PEEK(A%(9%)) AND 128%

POKE A%(10%),PEEK(A%(10%)) AND 128%

; CUR(20%,16%)'>> Tryck J f|r ny sor-'

; CUR(21%,16%)'   tering - annars N!';

GET G$ : IF G$='J' OR G$='j' 680

END

Of course, that was a lame joke Wink

The SORTDEMO.BAS mentioned by Moneo comes in the original QB45 distribution disks, which you can grab from my site (look at sig, it's back Wink

) or here http://www.dst.univ.trieste.it/OM/pm/QB45/SORTDEMO.BAS

(Warning! It's in binary format, you'll have to load it up in QB45 to see it)

I'd like to see the modified version as well Smile

Mitthrawnuruodo · 03-25-2005, 09:34 AM

No Nate, I think you hit it home with that hyeroglyph comment. :lol:

SBM Productions · 03-25-2005, 09:59 AM

and Blitz tells me my code is unreadable.....

Moneo · 03-26-2005, 06:58 AM

Ok, Nathan, here's my modified version of SORTDEMO.BAS which I used for my own testing.
Note: To compile you need to specify /E and /X parameters.
If you want to modify the program, see my comments up front.
*****

Code:
' SDEMO5.BAS: Has Winer sort, Moneo Sort, WinerStruct Sort

'             and now Winer's Qsort of 1992.

' ********   NOTE: When changing sort routine options, see:

'                  - DATA statement at about line 97

'                  - PRINT "choice ( 2 W H M 9 Q T < > )" in sub BOXINT

'                  - Option$ in sub SORTMENU

'                  - CASE statements in sub SORTMENU

' Based on the 6 "choices" of 2 W H M 9 Q  the following sort routines

' will be run:

' 2 = WinerStruct - This is a version structured by Edward Moneo of the

'                   original 1988 QSort algorithm by Ethan Winer.

' W = Winer       - The original 1988 QSort by Ethan Winer.

' H = HeapSort    - Heapsort from original SORTDEMO.BAS.

' M = MoneoSort   - A test by Edward Moneo which stuffs the records into an

'                   array based on their numeric key, and then picks up the

'                   "sorted" records sequentially from the array.

' 9 = Qsort       - The 1992 version of Ethan Winer's structured algorithm. 

' Q = QuickSort   - QuickSort from original SORTDEMO.BAS

'

' Note: All of the original SORTDEMO.BAS sort routines are still in the code.

'

'   Microsoft SortDemo - Sorting algorithm demonstration program

'   Copyright (C) Microsoft Corporation 1987-1990

'

' SORTDEMO.BAS graphically demonstrates six common sorting algorithms.  It

' prints 25 or 43 horizontal bars, all of different lengths and all in random

' order, then sorts the bars from smallest to longest.

'

' The program also uses SOUND statements to generate different pitches,

' depending on the location of the bar being printed. Note that the SOUND

' statements delay the speed of each sorting algorithm so you can follow

' the progress of the sort.  Therefore, the times shown are for comparison

' only. They are not an accurate measure of sort speed.

'

' If you use these sorting routines in your own programs, you may notice

' a difference in their relative speeds (for example, the exchange

' sort may be faster than the shell sort) depending on the number of

' elements to be sorted and how "scrambled" they are to begin with.

'

DEFINT A-Z      ' Default type integer.

' Declare FUNCTION and SUB procedures, and the number and type of arguments:

  DECLARE FUNCTION RandInt% (Lower, Upper)

  DECLARE SUB BoxInit ()

  DECLARE SUB BubbleSort ()

  DECLARE SUB CheckScreen ()

  DECLARE SUB DrawFrame (TopSide, BottomSide, LeftSide, RightSide)

  DECLARE SUB ElapsedTime (CurrentRow)

  DECLARE SUB MoneoSort (StartElement, NumOfElements)

  DECLARE SUB HeapSort ()

  DECLARE SUB Initialize ()

rem ...  DECLARE SUB InsertionSort ()

  DECLARE SUB PercolateDown (MaxLevel)

  DECLARE SUB PercolateUp (MaxLevel)

  DECLARE SUB PrintOneBar (Row)

  DECLARE SUB QuickSort (Low, High)

  DECLARE SUB Reinitialize ()

  DECLARE SUB ShellSort ()

  DECLARE SUB SortMenu ()

  DECLARE SUB SwapBars (Row1, Row2)

  DECLARE SUB ToggleSound (Row, Column)

  DECLARE SUB Winer (StartElement, NumOfElements)

  DECLARE SUB WinerStruct (StartElement, NumOfElements)

  DECLARE SUB QSort (StartEl, NumEls)

' Define the data type used to hold the information for each colored bar:

  TYPE SortType

     Length AS INTEGER         ' Bar length (the element compared

                               ' in the different sorts)

     ColorVal AS INTEGER       ' Bar color

     BarString AS STRING * 43  ' The bar (a string of 43 characters)

  END TYPE

' Declare global constants:

  CONST FALSE = 0, TRUE = NOT FALSE, LEFTCOLUMN = 49

  CONST NUMOPTIONS = 11, NUMSORTS = 6

' Declare global variables, and allocate storage space for them.  SortArray

' and SortBackup are both arrays of the data type SortType defined above:

  DIM SHARED SortArray(1 TO 43) AS SortType, SortBackup(1 TO 43) AS SortType

  DIM SHARED OptionTitle(1 TO NUMOPTIONS) AS STRING * 12

  DIM SHARED StartTime AS SINGLE

  DIM SHARED Foreground, Background, NoSound, Pause

  DIM SHARED Selection, MaxRow, InitRow, MaxColors

' Data statements for the different options printed in the sort menu:

  DATA 2_WinerStruct, Winer, Heap, Moneo, WinerQS92, Quick,

  DATA Toggle Sound, , <   (Slower), >   (Faster)

' Begin logic of module-level code:

  Initialize             ' Initialize data values.

  SortMenu               ' Print sort menu.

  WIDTH 80, InitRow      ' Restore original number of rows.

  COLOR 7, 0             ' Restore default color

  CLS

  END

' GetRow, MonoTrap, and RowTrap are error-handling routines invoked by

' the CheckScreen SUB procedure.  GetRow determines whether the program

' started with 25, 43, or 50 lines.  MonoTrap determines the current

' video adapter is monochrome.  RowTrap sets the maximum possible

' number of rows (43 or 25).

GetRow:

   IF InitRow = 50 THEN

      InitRow = 43

      RESUME

   ELSE

      InitRow = 25

      RESUME NEXT

   END IF

RowTrap:

   MaxRow = 25

   RESUME

' BoxInit:

'    Calls the DrawFrame procedure to draw the frame around the sort menu,

'    then prints the different options stored in the OptionTitle array.

'

SUB BoxInit STATIC

   DrawFrame 1, 22, LEFTCOLUMN - 3, 78

   LOCATE 3, LEFTCOLUMN + 2: PRINT "QBasic Sorting Demo";

   LOCATE 5

   FOR I = 1 TO NUMOPTIONS - 1

      LOCATE , LEFTCOLUMN: PRINT OptionTitle(I)

   NEXT I

   ' Don't print the last option (> Faster) if the length of the Pause

   ' is down to 1 clock tick:

   IF Pause > 1 THEN LOCATE , LEFTCOLUMN: PRINT OptionTitle(NUMOPTIONS);

   ' Turn sound on or off, then print the current value for NoSound:

   NoSound = NOT NoSound

   ToggleSound 12, LEFTCOLUMN + 12

   LOCATE NUMOPTIONS + 6, LEFTCOLUMN

   PRINT "Type first character of"

   LOCATE , LEFTCOLUMN

   PRINT "choice ( 2 W H M 9 Q T < > )"

   LOCATE , LEFTCOLUMN

   PRINT "or ESC key to end program: ";

END SUB

' BubbleSort:

'    The BubbleSort algorithm cycles through SortArray, comparing adjacent

'    elements and swapping pairs that are out of order.  It continues to

'    do this until no pairs are swapped.

'

SUB BubbleSort STATIC

   Limit = MaxRow

   DO

      Switch = FALSE

      FOR Row = 1 TO (Limit - 1)

         ' Two adjacent elements are out of order, so swap their values

         ' and redraw those two bars:

         IF SortArray(Row).Length > SortArray(Row + 1).Length THEN

            SWAP SortArray(Row), SortArray(Row + 1)

            SwapBars Row, Row + 1

            Switch = Row

         END IF

      NEXT Row

      ' Sort on next pass only to where the last switch was made:

      Limit = Switch

   LOOP WHILE Switch

END SUB

' CheckScreen:

'     Checks for type of monitor (VGA, EGA, CGA, or monochrome) and

'     starting number of screen lines (50, 43, or 25).

'

SUB CheckScreen STATIC

   ' Try locating to the 50th row; if that fails, try the 43rd. Finally,

   ' if that fails, the user was using 25-line mode:

   InitRow = 50

   ON ERROR GOTO GetRow

   LOCATE InitRow, 1

   ' Determine if monitor is Monochrome or color.

   LOCATE 1, 1

   PRINT "x"

   DEF SEG = &HB000

   IF PEEK(0) <> ASC("x") THEN

        MaxColors = 15

   ELSE

        LOCATE 1, 1

        PRINT "y"

        IF PEEK(0) <> ASC("y") THEN

            MaxColors = 15

        ELSE

            MaxColors = 2

        END IF

   END IF

   DEF SEG

   ' See if 43-line mode is accepted; if not, run this program in 25-line

   ' mode:

   MaxRow = 43

   ON ERROR GOTO RowTrap

   WIDTH 80, MaxRow

   ON ERROR GOTO 0              ' Turn off error trapping.

END SUB

' DrawFrame:

'   Draws a rectangular frame using the high-order ASCII characters Ã (201) ,

'   Â» (187) , Ã (200) , Â¼ (188) , Âº (186) , and Ã (205). The parameters

'   TopSide, BottomSide, LeftSide, and RightSide are the row and column

'   arguments for the upper-left and lower-right corners of the frame.

'

SUB DrawFrame (TopSide, BottomSide, LeftSide, RightSide) STATIC

   CONST ULEFT = 201, URIGHT = 187, LLEFT = 200, LRIGHT = 188

   CONST VERTICAL = 186, HORIZONTAL = 205

   FrameWidth = RightSide - LeftSide - 1

   LOCATE TopSide, LeftSide

   PRINT CHR$(ULEFT); STRING$(FrameWidth, HORIZONTAL); CHR$(URIGHT);

   FOR Row = TopSide + 1 TO BottomSide - 1

      LOCATE Row, LeftSide

      PRINT CHR$(VERTICAL); SPC(FrameWidth); CHR$(VERTICAL);

   NEXT Row

   LOCATE BottomSide, LeftSide

   PRINT CHR$(LLEFT); STRING$(FrameWidth, HORIZONTAL); CHR$(LRIGHT);

END SUB

' ElapsedTime:

'    Prints seconds elapsed since the given sorting routine started.

'    Note that this time includes both the time it takes to redraw the

'    bars plus the pause while the SOUND statement plays a note, and

'    thus is not an accurate indication of sorting speed.

'

SUB ElapsedTime (CurrentRow) STATIC

   CONST FORMAT = "  &###.### seconds  "

   ' Print current selection and number of seconds elapsed in

   ' reverse video:

   COLOR Foreground, Background

   LOCATE Selection + 4, LEFTCOLUMN - 2

   PRINT USING FORMAT; OptionTitle(Selection); TIMER - StartTime;

   IF NoSound THEN

      SOUND 30000, Pause            ' Sound off, so just pause.

   ELSE

      SOUND 60 * CurrentRow, Pause  ' Sound on, so play a note while

   END IF                           ' pausing.

   COLOR MaxColors, 0               ' Restore regular foreground and

                                    ' background colors.

END SUB

' ExchangeSort:

'   The ExchangeSort compares each element in SortArray - starting with

'   the first element - with every following element.  If any of the

'   following elements is smaller than the current element, it is exchanged

'   with the current element and the process is repeated for the next

'   element in SortArray.

'

SUB ExchangeSort STATIC

   FOR Row = 1 TO MaxRow

      SmallestRow = Row

      FOR J = Row + 1 TO MaxRow

         IF SortArray(J).Length < SortArray(SmallestRow).Length THEN

            SmallestRow = J

            ElapsedTime J

         END IF

      NEXT J

      ' Found a row shorter than the current row, so swap those

      ' two array elements:

      IF SmallestRow > Row THEN

         SWAP SortArray(Row), SortArray(SmallestRow)

         SwapBars Row, SmallestRow

      END IF

   NEXT Row

END SUB

' HeapSort:

'  The HeapSort procedure works by calling two other procedures - PercolateUp

'  and PercolateDown.  PercolateUp turns SortArray into a "heap," which has

'  the properties outlined in the diagram below:

'

'                               SortArray(1)

'                               /          \

'                    SortArray(2)           SortArray(3)

'                   /          \            /          \

'         SortArray(4)   SortArray(5)   SortArray(6)  SortArray(7)

'          /      \       /       \       /      \      /      \

'        ...      ...   ...       ...   ...      ...  ...      ...

'

'

'  where each "parent node" is greater than each of its "child nodes"; for

'  example, SortArray(1) is greater than SortArray(2) or SortArray(3),

'  SortArray(3) is greater than SortArray(6) or SortArray(7), and so forth.

'

'  Therefore, once the first FOR...NEXT loop in HeapSort is finished, the

'  largest element is in SortArray(1).

'

'  The second FOR...NEXT loop in HeapSort swaps the element in SortArray(1)

'  with the element in MaxRow, rebuilds the heap (with PercolateDown) for

'  MaxRow - 1, then swaps the element in SortArray(1) with the element in

'  MaxRow - 1, rebuilds the heap for MaxRow - 2, and continues in this way

'  until the array is sorted.

'

SUB HeapSort STATIC

   FOR I = 2 TO MaxRow

      PercolateUp I

   NEXT I

   FOR I = MaxRow TO 2 STEP -1

      SWAP SortArray(1), SortArray(I)

      SwapBars 1, I

      PercolateDown I - 1

   NEXT I

END SUB

' Initialize:

'    Initializes the SortBackup and OptionTitle arrays.  It also calls the

'    CheckScreen, BoxInit, and RandInt% procedures.

'

SUB Initialize STATIC

   DIM TempArray(1 TO 43)

   CheckScreen                  ' Check for monochrome or EGA and set

                                ' maximum number of text lines.

   FOR I = 1 TO MaxRow

      TempArray(I) = I

   NEXT I

   MaxIndex = MaxRow

   RANDOMIZE TIMER              ' Seed the random-number generator.

   FOR I = 1 TO MaxRow

      ' Call RandInt% to find a random element in TempArray between 1

      ' and MaxIndex, then assign the value in that element to BarLength:

      Index = RandInt%(1, MaxIndex)

      BarLength = TempArray(Index)

      ' Overwrite the value in TempArray(Index) with the value in

      ' TempArray(MaxIndex) so the value in TempArray(Index) is

      ' chosen only once:

      TempArray(Index) = TempArray(MaxIndex)

      ' Decrease the value of MaxIndex so that TempArray(MaxIndex) can't

      ' be chosen on the next pass through the loop:

      MaxIndex = MaxIndex - 1

      ' Assign the BarLength value to the .Length element, then store

      ' a string of BarLength block characters (ASCII 223: Ã) in the

      ' .BarString element:

      SortBackup(I).Length = BarLength

      SortBackup(I).BarString = STRING$(BarLength, 223)

      ' Store the appropriate color value in the .ColorVal element:

      IF MaxColors > 2 THEN

         SortBackup(I).ColorVal = (BarLength MOD MaxColors) + 1

      ELSE

         SortBackup(I).ColorVal = MaxColors

      END IF

   NEXT I

   FOR I = 1 TO NUMOPTIONS      ' Read SORTDEMO menu options and store

      READ OptionTitle(I)       ' them in the OptionTitle array.

   NEXT I

   CLS

   Reinitialize         ' Assign values in SortBackup to SortArray and draw

                        ' unsorted bars on the screen.

   NoSound = FALSE

   Pause = 2            ' Initialize Pause to 2 clock ticks (1/9 second).

   BoxInit              ' Draw frame for the sort menu and print options.

END SUB

' InsertionSort:

'   The InsertionSort procedure compares the length of each successive

'   element in SortArray with the lengths of all the preceding elements.

'   When the procedure finds the appropriate place for the new element, it

'   inserts the element in its new place, and moves all the other elements

'   down one place.

'

SUB InsertionSort STATIC

   DIM TempVal AS SortType

   FOR Row = 2 TO MaxRow

      TempVal = SortArray(Row)

      TempLength = TempVal.Length

      FOR J = Row TO 2 STEP -1

         ' As long as the length of the J-1st element is greater than the

         ' length of the original element in SortArray(Row), keep shifting

         ' the array elements down:

         IF SortArray(J - 1).Length > TempLength THEN

            SortArray(J) = SortArray(J - 1)

            PrintOneBar J               ' Print the new bar.

            ElapsedTime J               ' Print the elapsed time.

         ' Otherwise, exit the FOR...NEXT loop:

         ELSE

            EXIT FOR

         END IF

      NEXT J

      ' Insert the original value of SortArray(Row) in SortArray(J):

      SortArray(J) = TempVal

      PrintOneBar J

      ElapsedTime J

   NEXT Row

END SUB

' PercolateDown:

'   The PercolateDown procedure restores the elements of SortArray from 1 to

'   MaxLevel to a "heap" (see the diagram with the HeapSort procedure).

'

SUB PercolateDown (MaxLevel) STATIC

   I = 1

   ' Move the value in SortArray(1) down the heap until it has

   ' reached its proper node (that is, until it is less than its parent

   ' node or until it has reached MaxLevel, the bottom of the current heap):

   DO

      Child = 2 * I             ' Get the subscript for the child node.

      ' Reached the bottom of the heap, so exit this procedure:

      IF Child > MaxLevel THEN EXIT DO

      ' If there are two child nodes, find out which one is bigger:

      IF Child + 1 <= MaxLevel THEN

         IF SortArray(Child + 1).Length > SortArray(Child).Length THEN

            Child = Child + 1

         END IF

      END IF

      ' Move the value down if it is still not bigger than either one of

      ' its children:

      IF SortArray(I).Length < SortArray(Child).Length THEN

         SWAP SortArray(I), SortArray(Child)

         SwapBars I, Child

         I = Child

      ' Otherwise, SortArray has been restored to a heap from 1 to MaxLevel,

      ' so exit:

      ELSE

         EXIT DO

      END IF

   LOOP

END SUB

' PercolateUp:

'   The PercolateUp procedure converts the elements from 1 to MaxLevel in

'   SortArray into a "heap" (see the diagram with the HeapSort procedure).

'

SUB PercolateUp (MaxLevel) STATIC

   I = MaxLevel

   ' Move the value in SortArray(MaxLevel) up the heap until it has

   ' reached its proper node (that is, until it is greater than either

   ' of its child nodes, or until it has reached 1, the top of the heap):

   DO UNTIL I = 1

      Parent = I \ 2            ' Get the subscript for the parent node.

      ' The value at the current node is still bigger than the value at

      ' its parent node, so swap these two array elements:

      IF SortArray(I).Length > SortArray(Parent).Length THEN

         SWAP SortArray(Parent), SortArray(I)

         SwapBars Parent, I

         I = Parent

      ' Otherwise, the element has reached its proper place in the heap,

      ' so exit this procedure:

      ELSE

         EXIT DO

      END IF

   LOOP

END SUB

' PrintOneBar:

'  Prints SortArray(Row).BarString at the row indicated by the Row

'  parameter, using the color in SortArray(Row).ColorVal.

'

SUB PrintOneBar (Row) STATIC

   LOCATE Row, 1

   COLOR SortArray(Row).ColorVal

   PRINT SortArray(Row).BarString;

END SUB

' QuickSort:

'   QuickSort works by picking a random "pivot" element in SortArray, then

'   moving every element that is bigger to one side of the pivot, and every

'   element that is smaller to the other side.  QuickSort is then called

'   recursively with the two subdivisions created by the pivot.  Once the

'   number of elements in a subdivision reaches two, the recursive calls end

'   and the array is sorted.

'

SUB QuickSort (Low, High)

   IF Low < High THEN

      ' Only two elements in this subdivision; swap them if they are out of

      ' order, then end recursive calls:

      IF High - Low = 1 THEN

         IF SortArray(Low).Length > SortArray(High).Length THEN

            SWAP SortArray(Low), SortArray(High)

            SwapBars Low, High

         END IF

      ELSE

         ' Pick a pivot element at random, then move it to the end:

         RandIndex = RandInt%(Low, High)

         SWAP SortArray(High), SortArray(RandIndex)

         SwapBars High, RandIndex

         Partition = SortArray(High).Length

         DO

            ' Move in from both sides towards the pivot element:

            I = Low: J = High

            DO WHILE (I < J) AND (SortArray(I).Length <= Partition)

               I = I + 1

            LOOP

            DO WHILE (J > I) AND (SortArray(J).Length >= Partition)

               J = J - 1

            LOOP

            ' If we haven't reached the pivot element, it means that two

            ' elements on either side are out of order, so swap them:

            IF I < J THEN

               SWAP SortArray(I), SortArray(J)

               SwapBars I, J

            END IF

         LOOP WHILE I < J

         ' Move the pivot element back to its proper place in the array:

         SWAP SortArray(I), SortArray(High)

         SwapBars I, High

         ' Recursively call the QuickSort procedure (pass the smaller

         ' subdivision first to use less stack space):

         IF (I - Low) < (High - I) THEN

            QuickSort Low, I - 1

            QuickSort I + 1, High

         ELSE

            QuickSort I + 1, High

            QuickSort Low, I - 1

         END IF

      END IF

   END IF

END SUB

' RandInt%:

'   Returns a random integer greater than or equal to the Lower parameter

'   and less than or equal to the Upper parameter.

'

FUNCTION RandInt% (Lower, Upper) STATIC

   RandInt% = INT(RND * (Upper - Lower + 1)) + Lower

END FUNCTION

' Reinitialize:

'   Restores the array SortArray to its original unsorted state, then

'   prints the unsorted color bars.

'

SUB Reinitialize STATIC

   FOR I = 1 TO MaxRow

      SortArray(I) = SortBackup(I)

   NEXT I

   FOR I = 1 TO MaxRow

      LOCATE I, 1

      COLOR SortArray(I).ColorVal

      PRINT SortArray(I).BarString;

   NEXT I

   COLOR MaxColors, 0

END SUB

' ShellSort:

'  The ShellSort procedure is similar to the BubbleSort procedure.  However,

'  ShellSort begins by comparing elements that are far apart (separated by

'  the value of the Offset variable, which is initially half the distance

'  between the first and last element), then comparing elements that are

'  closer together (when Offset is one, the last iteration of this procedure

'  is merely a bubble sort).

'

SUB ShellSort STATIC

   ' Set comparison offset to half the number of records in SortArray:

   Offset = MaxRow \ 2

   DO WHILE Offset > 0          ' Loop until offset gets to zero.

      Limit = MaxRow - Offset

      DO

         Switch = FALSE         ' Assume no switches at this offset.

         ' Compare elements and switch ones out of order:

         FOR Row = 1 TO Limit

            IF SortArray(Row).Length > SortArray(Row + Offset).Length THEN

               SWAP SortArray(Row), SortArray(Row + Offset)

               SwapBars Row, Row + Offset

               Switch = Row

            END IF

         NEXT Row

         ' Sort on next pass only to where last switch was made:

         Limit = Switch - Offset

      LOOP WHILE Switch

      ' No switches at last offset, try one half as big:

      Offset = Offset \ 2

   LOOP

END SUB

' SortMenu:

'   The SortMenu procedure first calls the Reinitialize procedure to make

'   sure the SortArray is in its unsorted form, then prompts the user to

'   make one of the following choices:

'

'               * One of the sorting algorithms

'               * Turn sound on or off

'               * Increase or decrease speed

'               * End the program

'

SUB SortMenu STATIC

   Escape$ = CHR$(27)

   ' Create a string consisting of all legal choices:

   Option$ = "2WHM9Q><T" + Escape$

   DO

      ' Make the cursor visible:

      LOCATE NUMOPTIONS + 8, LEFTCOLUMN + 27, 1

      Choice$ = UCASE$(INPUT$(1))          ' Get the user's choice and see

      Selection = INSTR(Option$, Choice$)  ' if it's one of the menu options.

      ' User chose one of the sorting procedures:

      IF (Selection >= 1) AND (Selection <= NUMSORTS) THEN

         Reinitialize                      ' Rescramble the bars.

         LOCATE , , 0                      ' Make the cursor invisible.

         Foreground = 0                    ' Set reverse-video values.

         Background = 7

         StartTime = TIMER                 ' Record the starting time.

      END IF

      ' Branch to the appropriate procedure depending on the key pressed:

      SELECT CASE Choice$

         CASE "2"

            WinerStruct 1, MaxRow

         CASE "W"

            Winer 1, MaxRow

         CASE "H"

            HeapSort

         CASE "M"

            MoneoSort 1, MaxRow

         CASE "9"

            Qsort 1, MaxRow

         CASE "Q"

            QuickSort 1, MaxRow

         CASE ">"

            ' Decrease pause length to speed up sorting time, then redraw

            ' the menu to clear any timing results (since they won't compare

            ' with future results):

            Pause = (2 * Pause) / 3

            BoxInit

         CASE "<"

            ' Increase pause length to slow down sorting time, then redraw

            ' the menu to clear any timing results (since they won't compare

            ' with future results):

            IF (3 * Pause) / 2 < 13000 THEN Pause = (3 * Pause) / 2

            BoxInit

         CASE "T"

            ToggleSound 12, LEFTCOLUMN + 12

         CASE Escape$

            ' User pressed ESC, so exit this procedure and return to

            ' module level:

            EXIT DO

         CASE ELSE

            ' Invalid key

      END SELECT

      IF (Selection >= 1) AND (Selection <= NUMSORTS) THEN

         Foreground = MaxColors            ' Turn off reverse video.

         Background = 0

         ElapsedTime 0                     ' Print final time.

      END IF

   LOOP

END SUB

' SwapBars:

'   Calls PrintOneBar twice to switch the two bars in Row1 and Row2,

'   then calls the ElapsedTime procedure.

'

SUB SwapBars (Row1, Row2) STATIC

   PrintOneBar Row1

   PrintOneBar Row2

   ElapsedTime Row1

END SUB

' ToggleSound:

'   Reverses the current value for NoSound, then prints that value next

'   to the "Toggle Sound" option on the sort menu.

'

SUB ToggleSound (Row, Column) STATIC

   NoSound = NOT NoSound

   LOCATE Row, Column

   IF NoSound THEN

      PRINT ": OFF";

   ELSE

      PRINT ": ON ";

   END IF

END SUB

SUB Winer (StartElement, NumOfElements) STATIC

'********** QSort.Bas - sort routine algorithm demonstration

'Copyright (c) 1988 Ethan Winer, with special thanks to Eric Klien

'This program illustrates the algorithm used by the QuickPak Professional

'assembler string sorts, and is provided solely for its educational value.

    DIM Temp AS SortType

    REDIM QStack(500)  'create Stack (use 500 when sorting large arrays)

    S = 1               'initialize work variables

    F = StartElement

    L = StartElement + NumOfElements - 1

L1:

    Temp = SortArray((L + F) \ 2)         'seek midpoint

    I = F

    J = L

L2:

    WHILE SortArray(I).Length < Temp.Length: I = I + 1: WEND    'use > for descending

    WHILE SortArray(J).Length > Temp.Length: J = J - 1: WEND    'use < for descending

    IF I > J GOTO L3

    IF I < J THEN SWAP SortArray(I), SortArray(J): SwapBars I, J

    I = I + 1: J = J - 1

    IF I <= J GOTO L2

L3:

    IF I < L THEN

       QStack(S) = I             'Push I, L

       QStack(S + 1) = L

       S = S + 2

    END IF

    L = J

    IF F < L GOTO L1

    IF S = 1 GOTO L4

    S = S - 2                   'Pop L, F

    F = QStack(S)

    L = QStack(S + 1)

    GOTO L1

L4:

END SUB

SUB MoneoSort (El1, Num) STATIC

  amax = 43

  redim Index(1 to 999)

  redim Temp$(1 TO amax)

  for x=1 to Num

      l=sortarray(x).length

      index(l)=x               'stuff len slot with where it is

      if l>highlen then highlen=l

  next x

  for x=1 to highlen

      z=index(x)

      if z > 0 then

         temp$(x) = sortarray(z).barstring

         rem ...SUB PrintOneBar (Row) STATIC

         LOCATE z, 1

         COLOR 0,0              'COLOR SortArray(Row).ColorVal

         PRINT SortArray(z).BarString;

         ElapsedTime z

      end if

  next x

  for x=1 to amax

      sortarray(x).barstring=temp$(x)

      PrintOneBar x

      ElapsedTime x

  next x

END SUB

rem STRUCTURED VERSION OF QUICKPAK QUICK SORT BY ETHAN WINER.

SUB WinerStruct (StartElement, NumOfElements) STATIC

'********** QSort.Bas - sort routine algorithm demonstration

'Copyright (c) 1988 Ethan Winer, with special thanks to Eric Klien

'This program illustrates the algorithm used by the QuickPak Professional

'assembler string sorts, and is provided solely for its educational value.

    DIM Temp AS SortType

    REDIM QStack(500)  'create Stack (use 500 when sorting large arrays)

    S = 1               'initialize work variables

    F = StartElement

    L = StartElement + NumOfElements - 1

DO                    'L1:

    Temp = SortArray((L + F) \ 2)         'seek midpoint

    I = F

    J = L

  DO                   'L2:

    WHILE SortArray(I).Length < Temp.Length: I = I + 1: WEND    'use > for descending

    WHILE SortArray(J).Length > Temp.Length: J = J - 1: WEND    'use < for descending

    IF I > J THEN EXIT DO               ' GOTO L3

    IF I < J THEN SWAP SortArray(I), SortArray(J): SwapBars I, J

    I = I + 1: J = J - 1

  LOOP WHILE I <= J                     'IF I <= J GOTO L2

                       'L3:

    IF I < L THEN

       QStack(S) = I             'Push I, L

       QStack(S + 1) = L

       S = S + 2

    END IF

    L = J

    if F >= L then                         'IF F < L GOTO L1

       IF S = 1 THEN EXIT DO               'IF S = 1 GOTO L4

       S = S - 2                   'Pop L, F

       F = QStack(S)

       L = QStack(S + 1)

    end if

LOOP                                    'GOTO L1

                    'L4:

END SUB

'XXXXXXXXXXXXXXXXXXXXX added 9/5/98 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

'********* QSORT.BAS - Quick Sort algorithm demonstration

'Copyright (c) 1992 Ethan Winer

SUB QSort (StartEl, NumEls) STATIC

DIM Temp AS SortType

REDIM QStack(NumEls \ 5 + 10) 'create a stack

First = StartEl               'initialize work variables

Last = StartEl + NumEls - 1

StackPtr=0                    '(This was missing in Winer's code)

DO

  DO

    Temp = Sortarray((Last + First) \ 2)  'seek midpoint

    I = First

    J = Last

    DO     'reverse both < and > below to sort descending

      WHILE Sortarray(I).Length < Temp.Length

        I = I + 1

      WEND

      WHILE Sortarray(J).Length > Temp.Length

        J = J - 1

      WEND

      IF I > J THEN EXIT DO

      IF I < J THEN SWAP Sortarray(I), Sortarray(J) : SwapBars I, J

      I = I + 1

      J = J - 1

    LOOP WHILE I <= J

    IF I < Last THEN                    'Done

      QStack(StackPtr) = I              'Push I

      QStack(StackPtr + 1) = Last       'Push Last

      StackPtr = StackPtr + 2

    END IF

    Last = J

  LOOP WHILE First < Last

  IF StackPtr = 0 THEN EXIT DO

  StackPtr = StackPtr - 2

  First = QStack(StackPtr)              'Pop First

  Last = QStack(StackPtr + 1)           'Pop Last

LOOP

ERASE QStack               'delete the stack array

END SUB

na_th_an · 03-26-2005, 09:49 AM

Nice sorting routines. I've already CTRL+C/CTRL+V'ed all this code for future use. Thanks Smile

TheBigBasicQ · 03-26-2005, 01:53 PM

Moneo, you probably misunderstood what I was trying to say. Heap sort is the most "stable" IMO. Whatever the case, it will take the same time to sort the array unlike quick sort which will require O(n^2) in the worst case scenario.

SBM Productions · 03-26-2005, 05:36 PM

I didn't really take a good look at the code, but was radix sort implemented? Just for the record radix takes exactly the same time. I forget now what the formula was but time is linearly correlated to amount of numbers in data, regardless of the current state.

Moneo · 03-27-2005, 05:52 AM

NATHAN: Glad you could use the routines. Big Grin

BBQ: If you have a better implementation of the Heap sort, post it and I'll insert it into the demo and see how it performs. PS: I never use Quicksort in my programs. I don't like the fact that it does not maintain the original sequence of other keys. If I need to use a sort, I usually put the records onto a file and then do a SHELL to a sort utility, and read them back in. If I must sort in memory, I'll use a simple Shell sort algorithm that I have.

SBM: The Radix sort is not in the modified SortDemo. I have the original version on my old DOS machine. Give me time to check it.

*****

TheBigBasicQ · 03-28-2005, 08:47 PM

Moneo, heap sort is not faster than quick sort but its a 'stable' performer. I have the code in C if you want it.

Login
Username:
Password:	Lost Password?
	Remember me