POINT Software Programming/PPROG1.ISO/pascal/visionix/vsortu.pas

Pascal/Delphi Source File | 1993-12-29 | 13.0 KB | 616 lines

{
════════════════════════════════════════════════════════════════════════════

Visionix Sort (VSortu) Unit
   Version 0.7
 Copyright 1991,92,93 Visionix
 ALL RIGHTS RESERVED

────────────────────────────────────────────────────────────────────────────

 Revision history in reverse chronological order:

 Initials  Date      Comment
 ────────  ────────  ───────────────────────────────────────────────────────

 jrt       11/02/93  First logged revision.

════════════════════════════════════════════════════════════════════════════
}


(*-

[TEXT]


<Overview>

This unit implements a generic heap sort routine.

This overview will be enhanced in the next BETA release.

<Interface>

-*)

Unit VSortu;

Interface

Uses

  VTypesu,
  VStringu,
  VGenu;

{────────────────────────────────────────────────────────────────────────────}


Type

  TSortProc = Function( Var A; Var B ) : SHORTINT;
  PSortProc = ^TSortProc;


Procedure Sort(               Var Buf;
                                  Index         : WORD;
                                  Count         : WORD;
                                  SortProc      : PSortProc;
                                  Params        : STRING        );


{────────────────────────────────────────────────────────────────────────────}

Implementation

Var

  SortExSize : WORD;


Function  shortSortProc(      Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If ShortInt(A) < ShortInt(B) Then
    shortSortProc := -1
  Else
  If ShortInt(A) > ShortInt(B) Then
    shortSortProc := 1
  Else
    shortSortProc := 0;

END;

Function  byteSortProc(       Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If Byte(A) < Byte(B) Then
    byteSortProc := -1
  Else
  If Byte(A) > Byte(B) Then
    byteSortProc := 1
  Else
    byteSortProc := 0;

END;

Function  intSortProc(        Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If Integer(A) < Integer(B) Then
    intSortProc := -1
  Else
  If Integer(A) > Integer(B) Then
    intSortProc := 1
  Else
    intSortProc := 0;

END;

Function  wordSortProc(       Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If Word(A) < Word(B) Then
    wordSortProc := -1
  Else
  If Word(A) > Word(B) Then
    wordSortProc := 1
  Else
    wordSortProc := 0;

END;


Function  longSortProc(       Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If LongInt(A) < LongInt(B) Then
    longSortProc := -1
  Else
  If LongInt(A) > LongInt(B) Then
    longSortProc := 1
  Else
    longSortProc := 0;

END;

Function  strSortProc(        Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If String(A) < String(B) Then
    strSortProc := -1
  Else
  If String(A) > String(B) Then
    strSortProc := 1
  Else
    strSortProc := 0;

END;

Function  pstrSortProc(       Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If String(Pointer(A)^) < String(Pointer(B)^) Then
    pstrSortProc := -1
  Else
  If String(Pointer(A)^) > String(Pointer(B)^) Then
    pstrSortProc := 1
  Else
    pstrSortProc := 0;

END;


Function  pcharSortProc(      Var A;
                              Var B             ) : SHORTINT; Far;

Const

  NULL = #0;

Var

  L1   : WORD;

  StrA,
  StrB : PCharArray;

BEGIN

  pcharSortProc := 0;

  StrA := PCharArray(Pointer(A));
  StrB := PCharArray(Pointer(B));

  If (StrA^[1] = NULL) AND (StrB^[1] = NULL) Then
    Exit;

  If (StrA^[1] = NULL) OR (StrB^[1] = NULL) Then
  BEGIN

    If ( StrB^[1] = NULL ) Then
      pcharSortProc := -1
    Else
      pcharSortProc := 1;

    Exit;

  END;

  L1 := 1;

  While ( StrA^[L1] <> NULL ) AND
        ( StrB^[L1] <> NULL ) AND
        ( StrA^[L1] = StrB^[L1] ) Do
    Inc( L1 );

  If ( StrA^[L1] = StrB^[L1] ) Then
    Exit;

  If ( StrA^[L1] < StrB^[L1] ) Then
    pcharSortProc := -1
  Else
    pcharSortProc := 1;

END;

Function  realSortProc(       Var A;
                              Var B             ) : SHORTINT; Far;

BEGIN

  If Real(A) < Real(B) Then
    realSortProc := -1
  Else
  If Real(A) > Real(B) Then
    realSortProc := 1
  Else
    realSortProc := 0;

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure Sort(               Var Buf;
                                  Index         : LONGINT;
                                  Count         : LONGINT;
                                  SortProc      : PSortProc;
                                  Params        : STRING        );

[PARAMETERS]

Buf         Untyped pointer to the base of the data element array.
Index       Element within array to begin sorting.
Count       Number of elements to sort in the table.
SortProc    Pointer to a comparison function.
Params      Parameter string with specific sorting information.

[RETURNS]

Buf         Sorted buffer

[DESCRIPTION]

Sorts a table of data elements using the Heapsort algorithm.  A user-supplied
comparison function is allowed for maximum flexability - but not required for
ShortInt, Byte, Integer, Word, LongInt, String, PString, PChar, and Real
types, which are all auto-formatted.

For "user-supplied" types, SortProc should be a function which Sort uses for
element comparisons.  Sort will pass two pointers that address elements in
the table being sorted.  The function should follow the TSortProc template,
where a -1 should be returned if the first parameter is less that the second,
0 if the two parameters are equal, or +1 if the first parameter is greater
than the second.

The parameter string is a string containing a list of specific sorting
instructions to use.  The commands within the Params string must be comma
delimited with no spaces.

Parameter substrings are as follows:

  ElementType=$    Where $ is the type of element within the table.
                   Default is word type.

                   Allowed ElementTypes, preset ElementSize, and
                   kind of element for each include:

                   SHORTINT - 1    Ordinals
                   BYTE     - 1    Ordinals
                   INTEGER  - 2    Ordinals
                   WORD     - 2    Ordinals
                   LONGINT  - 4    Ordinals
                   STRING   - 256  Fixed-length (see below)
                   PSTRING  - 4    Pointers for Variant-length
                   PCHAR    - 4    Pointers for Variant-length
                   REAL     - 6    Floating-points

                   If the actual ElementSize for a String type is less
                   than 256 (ie. STRING[80]), use ElementSize afterwards to
                   reset to the lesser size.

                   If you are using an external compare function, then the
                   ElementType parameter should not be used.

  'ElementSize=#'  Where # is the size of each element within the table.
                   Default is 2, the size of a word.  Note that only User
                   types are not precasted in size, and must have this
                   parameter included.

[SEE-ALSO]

(None)

[EXAMPLE]

Var

  Table : Array[1..5] of STRING;

BEGIN

  Table[1] := 'ALPHA';
  Table[2] := 'CHARLIE';
  Table[3] := 'ECHO';
  Table[4] := 'DELTA';
  Table[5] := 'BRAVO';

  Sort( Table, 1, 5, NIL, 'ElementType=STRING' );

END;

-*)

{────────────────────────────────────────────────────────────────────────────}

Procedure Sort(               Var Buf;
                                  Index         : WORD;
                                  Count         : WORD;
                                  SortProc      : PSortProc;
                                  Params        : STRING        );

Var

  Child       : WORD;
  Cell        : WORD;
  TempBuf     : POINTER;
  ElementSize : WORD;

  Param       : STRING;
  ParamField  : STRING;
  ParamData   : STRING;

  Left        : WORD;
  Right       : WORD;

  DoSort      : TSortProc;

  {────────────────────────────────────────────────────────────────────────}

  Function RelToAbs( N : WORD ) : WORD;
  BEGIN

    RelToAbs := (N * ElementSize) - Pred(ElementSize);

  END;

  {────────────────────────────────────────────────────────────────────────}

  Procedure SiftSort( Parent, Top : WORD );

  Var

    P1,
    P2  : POINTER;

  Label
    Done;

  BEGIN

    Move( TByteArray(Buf)[RelToAbs(Parent)], TempBuf^, ElementSize );

    REPEAT

      Child := Parent;
      Inc(Child, Parent);
      If (Child > Top) Then
        Goto Done

      Else
      BEGIN

        If ( Child < Top ) Then
        BEGIN

          P1 := PtrAdd( @Buf, Pred(RelToAbs(Child)) );
          P2 := PtrAdd( @Buf, Pred(RelToAbs(Succ(Child))) );

          If ( DoSort( Pointer(P1^), Pointer(P2^) ) = -1 ) Then
            Inc( Child );

        END;

        {---}

        P1 := TempBuf;
        P2 := PtrAdd( @Buf, Pred(RelToAbs(Child)) );

        If DoSort( Pointer(P1^), Pointer(P2^) ) = -1 Then
        BEGIN

          Move( TByteArray(Buf)[RelToAbs(Child)],
                TByteArray(Buf)[RelToAbs(Parent)],
                ElementSize );

          Parent := Child;

        END
        Else
          Goto Done;

      END;

    Until (False);

    DONE:

    Move( TempBuf^,
          TByteArray(Buf)[RelToAbs(Parent)],
          ElementSize );

  END;

  {────────────────────────────────────────────────────────────────────────}

BEGIN

  {----------------------}
  { Initialize variables }
  {----------------------}

  ElementSize := 2;  { also defaults to sort WORD type }

  {------------------------}
  { Parse parameter string }
  {------------------------}

  Param := '';
  REPEAT

    Param := UpperString( GetNextParam( Param, Params ) );

    If Param <> '' Then
    BEGIN

      ParamField := GetParamName(Param);

      If ParamField = 'ELEMENTSIZE' Then
      BEGIN

        ParamData := GetParamData( Param );
        ElementSize := StrToInt( ParamData );

      END;

      If ParamField = 'ELEMENTTYPE' Then
      BEGIN

        ParamData := GetParamData( Param );

        If ParamData = 'SHORTINT' Then
        BEGIN

          SortProc    := @shortSortProc;
          ElementSize := SizeOf(ShortInt);

        END
        Else

        If ParamData = 'BYTE' Then
        BEGIN

          SortProc    := @byteSortProc;
          ElementSize := SizeOf(Byte);

        END
        Else

        If ParamData = 'INTEGER' Then
        BEGIN

          SortProc    := @intSortProc;
          ElementSize := SizeOf(Integer);

        END
        Else

        If ParamData = 'WORD' Then
        BEGIN

          SortProc    := @wordSortProc;
          ElementSize := SizeOf(Word);

        END
        Else

        If ParamData = 'LONGINT' Then
        BEGIN

          SortProc    := @longSortProc;
          ElementSize := SizeOf(LongInt);

        END
        Else

        If ParamData = 'STRING' Then
        BEGIN

          SortProc    := @strSortProc;
          ElementSize := SizeOf(String);

        END
        Else

        If ParamData = 'PSTRING' Then
        BEGIN

          SortProc    := @pstrSortProc;
          ElementSize := SizeOf(PString);

        END
        Else

        If ParamData = 'PCHAR' Then
        BEGIN

          SortProc    := @pcharSortProc;
          ElementSize := SizeOf(Pointer);

        END
        Else

        If ParamData = 'REAL' Then
        BEGIN

          SortProc    := @realSortProc;
          ElementSize := SizeOf(Real);

        END;

      END;

    END;

  UNTIL (Param = '');

  {----------------------------------------------}
  { Check to use default sort-checking procedure }
  {----------------------------------------------}

  If (SortProc = NIL) Then
    DoSort := wordSortProc
  Else
    DoSort := TSortProc(SortProc);

  {-----------------------}
  { Set global SortExSize }
  {-----------------------}

  SortExSize := ElementSize;

  {------------------}
  { Begin sorting... }
  {------------------}

  Left  := Index;
  Right := Index + Pred(Count);

  GetMem( TempBuf, ElementSize );

  For Cell := (Right DIV 2) DownTo (Succ(Left)) Do
    SiftSort( Cell, Right );

  For Cell := Right DownTo Succ(Left) Do
  BEGIN

    SiftSort( 1, Cell );

    SwapBuffers( TByteArray(Buf)[1],
                 TByteArray(Buf)[RelToAbs(Cell)],
                 ElementSize );

  END;

  FreeMem( TempBuf, ElementSize );

END;


{────────────────────────────────────────────────────────────────────────────}
{────────────────────────────────────────────────────────────────────────────}
{────────────────────────────────────────────────────────────────────────────}


BEGIN

END.