home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a006 / 1.ddi / PASSAMP.ZIP / SORT.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1991-03-11  |  7.9 KB  |  281 lines
  1. {$N+,E+}
  2. (*       Copyright (c) 1989 by Borland International, Inc.        *)
  3. program Sort;
  4.  
  5. uses
  6.   PXEngine;
  7. (*
  8.  *    SORT.PAS
  9.  *
  10.  *    This example program sorts a file on any combination of fields
  11.  *    in either ascending or descending order.
  12.  *
  13.  *    The algorithm supplied is a Shell sort.  However, since the
  14.  *    comparison and switch routines are generic, any sort algorithm
  15.  *    could be applied.  In addition, this file sort could be made
  16.  *    more efficient by employing an intelligent buffering
  17.  *    algorithm to help reducing disk accesses.
  18.  *
  19.  *    The program body is an example of how a command line file sort
  20.  *      program can be written.  The sort function could just as easily
  21.  *      be called from within an application.
  22.  *
  23.  *      Remark : Sorting only makes sense if the table is NOT indexed
  24.  *)
  25.  
  26. const
  27.   MAXFIELDNUMBER = 255;
  28.  
  29. type
  30.   SortOrderT = (ASCENDING, DESCENDING);
  31.  
  32. var                                     (* Globals *)
  33.   PXErr: Integer;                       (* last PX error *)
  34.   RecHandle1,                           (* handle to first comparison rec *)
  35.    RecHandle2: RecordHandle;            (* handle to second comparison rec *)
  36.   TblHandle: TableHandle;               (* global table handle *)
  37.   Fields: WordArray;                    (* fields which are relevant to
  38.                                            sortorder *)
  39.   I, H1, H2: Word;
  40.  
  41.  
  42. (*
  43.  *    Procedure:
  44.  *          Error
  45.  *
  46.  *    Arguments:
  47.  *          PXErr                   Paradox Engine error code
  48.  *
  49.  *    Description:
  50.  *          Prints the message of the error code stored in pxErr,
  51.  *              exits the engine, and terminates the program, if an error
  52.  *          occures.
  53.  *
  54.  *    Returns:
  55.  *          None
  56.  *)
  57. procedure Error(PXErr: Integer);
  58.  
  59.   begin
  60.     if PXErr <> 0 then
  61.       begin
  62.         WriteLn('Paradox Engine Error: ', PXErrMsg(PXErr));
  63.         if PXExit = 0 then; (* ignore return code *)
  64.         Halt(PXErr);
  65.       end;
  66.   end; (* Error *)
  67.  
  68.  
  69. (*
  70.  *    Function:
  71.  *          Compare
  72.  *
  73.  *    Arguments:
  74.  *          Field             Field handle of field to compare
  75.  *          SortOrder         ASCENDING or DESCENDING
  76.  *
  77.  *    Description:
  78.  *          Compares a given field of two records
  79.  *
  80.  *    Returns:
  81.  *          0                 Records are equal
  82.  *          < 0               Records need switching
  83.  *          > 0               Records are in sorted order
  84.  *)
  85. function Compare(Field: FieldHandle;
  86.                  SortOrder: SortOrderT): Integer;
  87.  
  88.   var
  89.     RH1, RH2: Word;
  90.     Long1, Long2: LongInt;
  91.     Short1, Short2: Integer;
  92.     Doub1, Doub2: Double;
  93.     Alpha1, Alpha2: String ;
  94.     FldType: NameString;
  95.  
  96.   begin
  97.     (* Setup records according to sortorder *)
  98.     if SortOrder = ASCENDING then
  99.       begin
  100.         RH1 := RecHandle1;
  101.         RH2 := RecHandle2;
  102.       end
  103.     else
  104.       begin
  105.         RH1 := RecHandle2;
  106.         RH2 := RecHandle1;
  107.       end;
  108.     (* Get field type *)
  109.     Error(PXFldType(TblHandle, Field, FldType));
  110.     (* Compare fields *)
  111.     case FldType[1] of
  112.       'D':
  113.         begin
  114.           Error(PXGetDate(RH1, Field, Long1));
  115.           Error(PXGetDate(RH2, Field, Long2));
  116.           Compare := Long2 - Long1;
  117.         end;
  118.       'S':
  119.         begin
  120.           Error(PXGetShort(RH1, Field, Short1));
  121.           Error(PXGetShort(RH2, Field, Short2));
  122.           Compare := Short2 - Short1;
  123.         end;
  124.       'A':
  125.         begin
  126.           Error(PXGetAlpha(RH1, Field, Alpha1));
  127.           Error(PXGetAlpha(RH2, Field, Alpha2));
  128.           if Alpha2 < Alpha1 then
  129.             Compare := - 1
  130.           else if Alpha2 > Alpha1 then
  131.             Compare := 1
  132.           else
  133.             Compare := 0;
  134.         end;
  135.       'N', '$':
  136.         begin
  137.           Error(PXGetDoub(RH1, Field, Doub1));
  138.           Error(PXGetDoub(RH2, Field, Doub2));
  139.           if Doub2 < Doub1 then
  140.             Compare := - 1
  141.           else if Doub2 > Doub1 then
  142.             Compare := 1
  143.           else
  144.             Compare := 0;
  145.         end
  146.       else Compare := 0;
  147.     end; (* CASE *)
  148.   end; (* Compare *)
  149.  
  150.  
  151. (*
  152.  *    Procedure:
  153.  *          ProcessElement
  154.  *
  155.  *    Arguments:
  156.  *          Rec1                    Record number of first comparison record
  157.  *          Rec2                    Record number of second comparison record
  158.  *          NFields                       Number of fields to use in sort comparison
  159.  *          Fields                        Array of fieldhandles
  160.  *          SortOrder               ASCENDING or DESCENDING
  161.  *
  162.  *    Description:
  163.  *          Compares two record numbers and exchanges them if needed
  164.  *
  165.  *    Returns:
  166.  *          None
  167.  *)
  168. procedure ProcessElement(Rec1, Rec2: RecordNumber;
  169.                          NFields: Integer;
  170.                          Fields: WordArray;
  171.                          SortOrder: SortOrderT);
  172.  
  173.   var
  174.     NeedSwitch: Boolean;
  175.     I, Ret: Integer;
  176.  
  177.   begin
  178.     (* Get the records *)
  179.     Error(PXRecGoto(TblHandle, Rec1));
  180.     Error(PXRecGet(TblHandle, RecHandle1));
  181.     Error(PXRecGoto(TblHandle, Rec2));
  182.     Error(PXRecGet(TblHandle, RecHandle2));
  183.     (* Compare each field *)
  184.     I := 1;
  185.     Ret := 0;
  186.     while (I <= NFields) and (Ret = 0) do
  187.       begin
  188.         Ret := Compare(Fields[I], SortOrder);
  189.         NeedSwitch := Ret < 0;
  190.         Inc(I);
  191.       end;
  192.     (* Switch and update if needed *)
  193.     if NeedSwitch then
  194.       begin
  195.         Error(PXRecGoto(TblHandle, Rec1));
  196.         Error(PXRecUpdate(TblHandle, RecHandle2));
  197.         Error(PXRecGoto(TblHandle, Rec2));
  198.         Error(PXRecUpdate(TblHandle, RecHandle1));
  199.       end;
  200.   end; (* ProcessElement *)
  201.  
  202.  
  203. (*
  204.  *    Procedure:
  205.  *          TableSort
  206.  *
  207.  *    Arguments:
  208.  *          TblName                       Name of table to sort
  209.  *          NFields                       Number of fields to use in sort
  210.  *          Fields                        Array of field handles
  211.  *          SortOrder               ASCENDING or DESCENDING
  212.  *
  213.  *    Description:
  214.  *          Sorts a table using a standard Shell sort on a given
  215.  *          table
  216.  *
  217.  *    Returns:
  218.  *          None
  219.  *)
  220. procedure TableSort(TblName: String ;
  221.                     NFields: Integer;
  222.                     Fields: WordArray;
  223.                     SortOrder: SortOrderT);
  224.  
  225.   var
  226.     Span,                               (* span of current sort *)
  227.      NRecs: LongInt;
  228.     I: Integer;                         (* Shell sort counter *)
  229.  
  230.   begin
  231.     (* Open table with buffering *)
  232.     Error(PXTblOpen(TblName, TblHandle, 0, True));
  233.     (* Get number of recs *)
  234.     Error(PXTblNRecs(TblHandle, NRecs));
  235.     (* Allocate 2 record handles *)
  236.     Error(PXRecBufOpen(TblHandle, RecHandle1));
  237.     Error(PXRecBufOpen(TblHandle, RecHandle2));
  238.     (* Perform Shell sort on records *)
  239.     for Span := NRecs div 2 downto 1 do
  240.       for I := 1 to NRecs - Span do
  241.         ProcessElement(I, I + Span, NFields, Fields, SortOrder);
  242.     (* Deallocate everything *)
  243.     Error(PXRecBufClose(RecHandle1));
  244.     Error(PXRecBufClose(RecHandle2));
  245.     Error(PXTblClose(TblHandle));
  246.   end; (* TableSort *)
  247.  
  248.  
  249. (*      Main program
  250.  *
  251.  *
  252.  *    Description:
  253.  *            This is an example of how a table sort can
  254.  *            be implemented
  255.  *
  256.  *      Command line arguments are as follows:
  257.  *          sort <tablename> <sortorder> <field1>...<fieldN>
  258.  *            tablename       Name of table to sort
  259.  *            sortorder       0=ascending, 1=descending
  260.  *            field1..N       field handles to sort on
  261.  *
  262.  *    Returns:
  263.  *              Exit Code
  264.  *)
  265. begin
  266.   (* Initialize Engine *)
  267.   Error(PXInit);
  268.   (* Store field handles in an array *)
  269.   for I := 3 to ParamCount do
  270.     begin
  271.       Val(ParamStr(I), H1, H2);
  272.       Fields[I - 2] := H1;
  273.     end;
  274.   (* Call the sort *)
  275.   Val(ParamStr(2), H1, H2);
  276.   TableSort(ParamStr(1), ParamCount - 2, Fields, SortOrderT(H1));
  277.   (* End Engine *)
  278.   PX(PXExit);
  279. end.
  280. 
  281.