home *** CD-ROM | disk | FTP | other *** search
/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / misc / qsort.src < prev    next >
Encoding:
Text File  |  1988-05-03  |  7.2 KB  |  249 lines
  1. ::::::::::
  2. QSORT.PRO
  3. ::::::::::
  4.  
  5. -------- SIMTEL20 Ada Software Repository Prologue ------------
  6. --                                                           -*
  7. -- Unit name    : generic procedure SORT
  8. -- Version      : 1.0
  9. -- Author       : John A. Anderson
  10. --              : TEXAS INSTRUMENTS MS 8006
  11. --              : P.O. BOX 801
  12. --              : MCKINNEY, TEXAS   75069
  13. --              :
  14. -- DDN Address  : ANDERSON%TI-EG at CSNET-RELAY
  15. -- Copyright    : (c) 1984, 1985 John Anderson
  16. -- Date created :  December 19, 1984
  17. -- Release Date : January 10, 1985
  18. -- Last update  :  ANDERSON Wed Dec 19, 1984
  19. -- Machine/System Compiled/Run on : DG MV 10000, Ada Development 
  20. --                                :   Environment
  21. --                                                           -*
  22. ---------------------------------------------------------------
  23. --                                                           -*
  24. -- Abstract     :  This generic procedure uses the QuickSort
  25. ----------------:  algorithm to sort an array of any base type
  26. ----------------:  with any discrete index type.
  27. ----------------:   Associated Files:
  28. ----------------:       SORT.ADA      -- generic Quick Sort
  29. ----------------:       OTHERTEST.ADA -- test program (for any
  30. ----------------:          generic sort with the same visible section
  31. ----------------:
  32. ------------------ Revision history ---------------------------
  33. --
  34. -- DATE         AUTHOR                  HISTORY
  35. -- 10 Jan 85      John Anderson        Initial Release
  36. --
  37. -------------------END-PROLOGUE--------------------------------
  38.  
  39. ::::::::::
  40. SORT.ADA
  41. ::::::::::
  42.  
  43.  
  44. -------- SIMTEL20 Ada Software Repository Prologue ------------
  45. --                                                           -*
  46. -- Unit name    : generic procedure SORT
  47. -- Version      : 1.0
  48. -- Author       : John A. Anderson
  49. --              : TEXAS INSTRUMENTS MS 8006
  50. --              : P.O. BOX 801
  51. --              : MCKINNEY, TEXAS   75069
  52. --              :
  53. -- DDN Address  : ANDERSON%TI-EG at CSNET-RELAY
  54. -- Copyright    : (c) 1984, 1985 John Anderson
  55. -- Date created :  December 19, 1984
  56. -- Release Date : January 10, 1985
  57. -- Last update  :  ANDERSON Wed Dec 19, 1984
  58. -- Machine/System Compiled/Run on : DG MV 10000, Ada Development 
  59. --                                :   Environment
  60. --                                                           -*
  61. ---------------------------------------------------------------
  62. --                                                           -*
  63. -- Abstract     :  This generic procedure uses the QuickSort
  64. ----------------:  algorithm to sort an array of any base type
  65. ----------------:  with any discrete index type.
  66. ----------------:   Associated Files:
  67. ----------------:       SORT.ADA      -- generic Quick Sort
  68. ----------------:       OTHERTEST.ADA -- test program (for any
  69. ----------------:          generic sort with the same visible section
  70. ----------------:
  71. ------------------ Revision history ---------------------------
  72. --
  73. -- DATE         AUTHOR                  HISTORY
  74. -- 10 Jan 85      John Anderson        Initial Release
  75. --
  76. -------------------END-PROLOGUE--------------------------------
  77. generic
  78.     type ITEM is private;
  79.  
  80.     type INDEX is (<>);
  81.  
  82.     type ROW is array (INDEX range <>) of ITEM;
  83.  
  84.     with function "<" (X, Y : ITEM) return BOOLEAN is <>;
  85.  
  86. procedure SORT (A : in out ROW);
  87.  
  88.  
  89. with TEXT_IO;
  90. procedure SORT (A : in out ROW) is
  91.  
  92.     procedure QSORT (L, R : INDEX) is
  93.  
  94.         I, J : INDEX;
  95.         X    : ITEM;
  96.  
  97.         procedure EXCHANGE (A, B : in out ITEM) is
  98.             TEMP : ITEM;
  99.         begin
  100.             TEMP := A;
  101.             A := B;
  102.             B := TEMP;
  103.         end EXCHANGE;
  104.  
  105.     begin
  106.  
  107.         I := L;
  108.         J := R;
  109.  
  110.         X := A (INDEX'VAL ((INDEX'POS (L) + INDEX'POS (R)) / 2));
  111.  
  112.         MAIN:
  113.         loop
  114.  
  115.             while A (I) < X loop
  116.                 I := INDEX'SUCC (I);
  117.             end loop;
  118.  
  119.             while X < A (J) loop
  120.                 J := INDEX'PRED (J);
  121.             end loop;
  122.  
  123.             if I <= J then
  124.                 EXCHANGE (A (I), A (J));
  125.  
  126.                 begin
  127.                     I := INDEX'SUCC (I);
  128.                     J := INDEX'PRED (J);
  129.                 exception
  130.                     when CONSTRAINT_ERROR =>
  131.                         null; -- necessary to avoid exception raising
  132.                 end;
  133.  
  134.             end if;
  135.  
  136.             exit when I > J;
  137.  
  138.         end loop MAIN;
  139.  
  140.         if L < J then
  141.             QSORT (L, J);
  142.         end if;
  143.  
  144.         if I < R then
  145.             QSORT (I, R);
  146.         end if;
  147.  
  148.     end QSORT;
  149.  
  150. begin
  151.  
  152.     QSORT (A'FIRST, A'LAST);
  153.  
  154. exception
  155.     when others =>
  156.         TEXT_IO.PUT_LINE ("Exception raised in Generic Sort");
  157.         raise;
  158. end SORT;
  159.  
  160. ::::::::::
  161. OTHERTEST.ADA
  162. ::::::::::
  163.  
  164. with SORT;
  165. with TEXT_IO;
  166. procedure OTHERTEST is
  167.  
  168.     MAX : constant INTEGER := 100;
  169.     subtype INDEX_TYPE is INTEGER range 1 .. MAX;
  170.     type MY_ARRAY_TYPE is array (INDEX_TYPE range <>) of INTEGER;
  171.  
  172.     OTHER_MAX : constant CHARACTER := 'Z';
  173.     subtype OTHER_INDEX_TYPE is CHARACTER range 'A' .. 'Z';
  174.     type OTHER_ARRAY_TYPE is array (OTHER_INDEX_TYPE range <>) of CHARACTER;
  175.  
  176.  
  177.     MY_ARRAY    : MY_ARRAY_TYPE (INDEX_TYPE);
  178.     OTHER_ARRAY : OTHER_ARRAY_TYPE (OTHER_INDEX_TYPE);
  179.  
  180.     procedure MY_SORT is new SORT
  181.                (ITEM => INTEGER, INDEX => INDEX_TYPE, ROW => MY_ARRAY_TYPE);
  182.  
  183.     procedure OTHER_SORT is new SORT
  184.                (ITEM  => CHARACTER,
  185.                 INDEX => OTHER_INDEX_TYPE,
  186.                 ROW   => OTHER_ARRAY_TYPE);
  187.  
  188. begin
  189.  
  190.     for NUM in INDEX_TYPE loop
  191.         MY_ARRAY (NUM) := 1000 - NUM * 2;
  192.     end loop;
  193.  
  194.     TEXT_IO.PUT_LINE ("The array consists of:");
  195.     for NUM in INDEX_TYPE loop
  196.         TEXT_IO.PUT_LINE (INTEGER'IMAGE (MY_ARRAY (NUM)));
  197.     end loop;
  198.  
  199.     MY_SORT (MY_ARRAY (1 .. 50));
  200.  
  201.     TEXT_IO.PUT_LINE ("The array sorted 1..50  consists of:");
  202.     for NUM in INDEX_TYPE loop
  203.         TEXT_IO.PUT_LINE (INTEGER'IMAGE (MY_ARRAY (NUM)));
  204.     end loop;
  205.  
  206.     MY_SORT (MY_ARRAY);
  207.  
  208.     TEXT_IO.PUT_LINE ("The array all sorted consists of:");
  209.     for NUM in INDEX_TYPE loop
  210.         TEXT_IO.PUT_LINE (INTEGER'IMAGE (MY_ARRAY (NUM)));
  211.     end loop;
  212.  
  213. -- load character array
  214.     for CHAR in OTHER_INDEX_TYPE loop
  215.         OTHER_ARRAY (CHAR) := CHARACTER'VAL
  216.                                 (CHARACTER'POS ('Z') - CHARACTER'POS (CHAR) +
  217.                                  CHARACTER'POS ('A'));
  218.     end loop;
  219.  
  220.     TEXT_IO.PUT_LINE ("The character array consists of:");
  221.     for CHAR in OTHER_INDEX_TYPE loop
  222.         TEXT_IO.PUT (OTHER_ARRAY (CHAR));
  223.         TEXT_IO.NEW_LINE;
  224.     end loop;
  225.  
  226.     OTHER_SORT (OTHER_ARRAY ('A' .. 'M'));
  227.  
  228.     TEXT_IO.PUT_LINE ("The array sorted A - M is");
  229.  
  230.     for CHAR in OTHER_INDEX_TYPE loop
  231.         TEXT_IO.PUT (OTHER_ARRAY (CHAR));
  232.         TEXT_IO.NEW_LINE;
  233.     end loop;
  234.  
  235.     OTHER_SORT (OTHER_ARRAY);
  236.  
  237.     TEXT_IO.PUT_LINE ("The character array sorted is");
  238.  
  239.     for CHAR in OTHER_INDEX_TYPE loop
  240.         TEXT_IO.PUT (OTHER_ARRAY (CHAR));
  241.         TEXT_IO.NEW_LINE;
  242.     end loop;
  243.  
  244. exception
  245.     when others => 
  246.         TEXT_IO.PUT_LINE ("Error in Main Program");
  247. end OTHERTEST;
  248.  
  249.