home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / mailpro / so.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-23  |  7.9 KB  |  262 lines
  1. unit SO;
  2.  
  3. interface
  4. uses Crt,   Def,    ColorDef, FT,       CursorOU, RE,      FastWr, DrawSqar,
  5.      CPaU,  UCasU,  SetBU,    LPaU,     GetKeU;
  6. procedure InPlaceSort( StartRec: integer);
  7. procedure InsertSort;
  8. procedure MergeSort;
  9. procedure SortQuery(var Continue : boolean);
  10.  
  11. implementation
  12.  
  13. procedure InPlaceSort;
  14. var Continue:                    boolean;
  15.     RecordNum:                   integer;
  16.     Above,
  17.     Below:                       MainRecordType;
  18. begin
  19. CursorOn(false);
  20. GetRec(HoldEntry,StartRec);
  21. DrawSquare( 30, 11, 50, 13, Msgs.Attr, true);
  22. FastWrite( CPad('Sorting',10), 12, 35, (Msgs.Attr or $0080));
  23. while Continue do
  24.    begin
  25.    if StartRec <> FileTop then
  26.       GetRec(Above,succ(StartRec))
  27.      else
  28.       Above := HoldEntry;
  29.    if StartRec <> 1 then
  30.       GetRec(Below,pred(StartRec))
  31.      else
  32.       Below := HoldEntry;
  33.    if  (UCase(HoldEntry.Addressee) >= UCase(Below.Addressee))
  34.    and (UCase(HoldEntry.Addressee) <= UCase(Above.Addressee)) then
  35.        Continue := false                           (* if..then 1 *)
  36.      else
  37.       begin
  38.       if UCase(HoldEntry.Addressee)  >  UCase(Above.Addressee) then
  39.          begin                                     (* if..then 2 *)
  40.          GetRec(Entry,succ(StartRec));
  41.          PutRec(Entry,StartRec);
  42.          inc(StartRec);
  43.          end
  44.       else
  45.          begin
  46.          GetRec(Entry,pred(StartRec));
  47.          PutRec(Entry,StartRec);
  48.          dec(StartRec);
  49.          end;      (* if..then..else 2 *)
  50.       end;         (* if..then..else 1 *)
  51.    end;            (* while loop *)
  52. PutRec(HoldEntry,StartRec);
  53. CursorOn(true);
  54. end;
  55.  
  56. (* -------------------------------------------------------------------- *)
  57.  
  58. procedure InsertSort;
  59. var Found:                    boolean;
  60.     TempStr:                  S10;
  61.     Start,
  62.     N,
  63.     K,
  64.     I:                        integer;
  65. begin
  66. SetBG;
  67. clrscr;
  68. CursorOn(false);
  69. FastWrite( CPad('Sorting',20), 1, 30, (Msgs.Attr or $0080));
  70. DrawSquare( 30, 9, 50, 14, Headings.Attr, true);
  71. FastWrite( CPad('Top of file',18), 10, 31, Headings.Attr);
  72. str(FileTop, TempStr);
  73. FastWrite( CPad(TempStr,10), 11, 35, Headings.Attr);
  74. FastWrite( CPad('Sorting',18), 12, 31, Headings.Attr);
  75. if FileTop  >  1 then
  76.    begin
  77.    Start := succ(SortTop);
  78.    for N := Start to FileTop do
  79.        begin
  80.        str(N,TempStr);
  81.        FastWrite( CPad(TempStr,10), 13, 35, Msgs.Attr);
  82.        GetRec(Entry,N);                      (* get sort Entry *)
  83.        HoldEntry := Entry;                   (* save for later *)
  84.        TestName := Entry.Addressee;
  85.        K := pred(N);
  86.        Found := false;
  87.        while (not Found) and (K > 0) do
  88.            begin                                    (* search list in *)
  89.            GetRec(Entry,K);                         (* descending order *)
  90.            if UCase(Entry.Addressee)  >  UCase(TestName) then
  91.               begin                                 (* move each Entry *)
  92.               PutRec(Entry,succ(K));                (* upward *)
  93.               dec(K);
  94.               end
  95.            else                                   (* until proper *)
  96.               begin                               (* place is *)
  97.               PutRec(HoldEntry,succ(K));
  98.               Found := true;                      (* Found *)
  99.               end;  (* if..then..else *)
  100.            end;     (* while *)
  101.        if not Found then PutRec(HoldEntry,1);
  102.        inc(SortTop);
  103.        PutFileTop;
  104.        end;         (* for..next loop *)
  105.    end;             (* other for..next loop *)
  106. CursorOn(true);
  107. end;
  108.  
  109. (* -------------------------------------------------------------------- *)
  110.  
  111. procedure MergeSort;
  112. var GetPoint,
  113.     PutPoint,
  114.     TempTop,
  115.     UseTop,
  116.     J,
  117.     I:            integer;
  118.     FromArray:    boolean;
  119.     TempStr:      S10;
  120.     Entries:      array [0..100] of MainRecordType;
  121.  
  122.     procedure DoMerge;
  123.     var Continue:         boolean;
  124.         J,
  125.         I:                integer;
  126.         TempStr:          S10;
  127.     begin
  128.     FastWrite( CPad('sorting',10), 1, 30, (Msgs.Attr or $0080));
  129.     FastWrite( LPad('top of file :',18), 3, 30, Headings.Attr);
  130.     FastWrite( LPad('sorted Entries :',18), 5, 30, Headings.Attr);
  131.     FastWrite( LPad('testing :',18), 7, 30, Headings.Attr);
  132.     FastWrite( LPad('reading to :',18), 9, 30, Headings.Attr);
  133.     FastWrite( LPad('sorting to :',18), 11, 30, Headings.Attr);
  134.     FastWrite( LPad('placing :',18), 13, 30, Headings.Attr);
  135.     str(FileTop:5,TempStr);
  136.     FastWrite( TempStr, 3, 50, Msgs.Attr);
  137.     str(SortTop:5,TempStr);
  138.     FastWrite( TempStr, 5, 50, Msgs.Attr);
  139.     Continue := true;
  140.     I := 1;
  141.     while Continue do
  142.        begin
  143.        if (I mod 5) = 0 then
  144.           begin
  145.           str(I:5,TempStr);
  146.           FastWrite( TempStr, 7, 50, Msgs.Attr);
  147.           end;
  148.        GetRec(Entry,I);
  149.        GetRec(HoldEntry,succ(I));
  150.        if UCase(Entry.Addressee)  >  UCase(HoldEntry.Addressee) then
  151.           begin
  152.           SortTop := I;
  153.           Continue := false;
  154.           end
  155.          else
  156.           begin
  157.           inc(I);
  158.           if I >= SortTop then Continue := false;
  159.           end;
  160.        end;
  161.     PutPoint := 0;
  162.     UseTop := SortTop + 100;
  163.     if UseTop > FileTop then UseTop := FileTop;
  164.     for I := succ(SortTop) to UseTop do
  165.         begin
  166.         str(I:5,TempStr);
  167.         FastWrite( TempStr, 9, 50, Msgs.Attr);
  168.         GetRec(Entry,I);
  169.         inc(PutPoint);
  170.         Entries[PutPoint] := Entry;
  171.         end;
  172.     TempTop := PutPoint;
  173.     for J := TempTop downto 2 do
  174.         begin
  175.         str(succ(UseTop)-J:5,TempStr);
  176.         FastWrite( TempStr, 11, 50, Msgs.Attr);
  177.         for I := 1 to pred(J) do
  178.             if UCase(Entries[J].Addressee)  < UCase(Entries[I].Addressee) then
  179.                begin
  180.                Entries[0] := Entries[J];
  181.                Entries[J] := Entries[I];
  182.                Entries[I] := Entries[0];
  183.                end;
  184.         end;
  185.     str(UseTop:5,TempStr);
  186.     FastWrite( TempStr, 11, 50, Msgs.Attr);
  187.     PutPoint := UseTop;
  188.     GetPoint := SortTop;
  189.     str(succ(UseTop)-TempTop:5,TempStr);
  190.     FastWrite( TempStr, 13, 50, Msgs.Attr);
  191.     while TempTop > 0 do
  192.        begin
  193.        if GetPoint > 0 then
  194.           begin
  195.           GetRec(Entry,GetPoint);
  196.           if UCase(Entries[TempTop].Addressee)  >  UCase(Entry.Addressee) then
  197.              FromArray := true
  198.             else
  199.              FromArray := false;
  200.           end
  201.          else
  202.           begin
  203.           FromArray := true;
  204.           end;
  205.        if FromArray then
  206.           begin
  207.           PutRec(Entries[TempTop],PutPoint);
  208.           dec(TempTop);
  209.           dec(PutPoint);
  210.           str(succ(UseTop)-TempTop:5,TempStr);
  211.           FastWrite( TempStr, 13, 50, Msgs.Attr);
  212.           end
  213.          else
  214.           begin
  215.           GetRec(Entry,GetPoint);
  216.           PutRec(Entry,PutPoint);
  217.           dec(PutPoint);
  218.           dec(GetPoint);
  219.           end;
  220.        end;                  (* end while *)
  221.     SortTop := UseTop;
  222.     PutFileTop;
  223.     if FileTop <> SortTop then DoMerge;
  224.     end;
  225.  
  226. begin
  227. clrscr;
  228. CursorOn(false);
  229. DoMerge;
  230. CursorOn(true);
  231. end;
  232.  
  233. (* -------------------------------------------------------------------- *)
  234.  
  235. procedure SortQuery;
  236. var Ch:                  char;
  237.     FunctionKey:         boolean;
  238.     TempStr:             S10;
  239. begin
  240. SetBG;
  241. clrscr;
  242. DrawSquare( 5, 9, 75, 12, Msgs.Attr, true);
  243. str(FileTop:5,TempStr);
  244. FastWrite( CPad('There are '+TempStr+' total  entries in the file.',60),
  245.           10, 10, Msgs.Attr);
  246. str(SortTop:5,TempStr);
  247. FastWrite( CPad('There are '+TempStr+' sorted entries in the file.',60),
  248.           11, 10, Msgs.Attr);
  249. DrawSquare( 15, 14, 65, 16, Inputs.Attr, true);
  250. FastWrite( CPad('Would you like to sort at this time ?',40),
  251.           15, 20, Inputs.Attr);
  252. Ch := ' ';
  253. while (Ch <> 'Y') and (Ch <> 'N') do
  254.     begin
  255.     GetKey(Ch,FunctionKey);
  256.     Ch := upcase(Ch);
  257.     end;
  258. if Ch = 'Y' then Continue := true else Continue := false;
  259. end;
  260.  
  261. end.
  262.