home *** CD-ROM | disk | FTP | other *** search
/ The Unsorted BBS Collection / thegreatunsorted.tar / thegreatunsorted / programming / misc_programming / TEST / GSORT.ADA < prev    next >
Encoding:
Text File  |  1990-06-28  |  1.1 KB  |  57 lines
  1. generic
  2.   type index is (<>);
  3.   type elem is private;
  4.   type vector is array(index range <>) of elem;
  5.   with function gt(a,b: elem) return boolean;
  6.   with procedure putaux(x: elem);
  7. package gsort is
  8.   procedure put(v: vector);
  9.   procedure sort(v: in out vector);
  10. end;
  11.  
  12. with ada_io; use ada_io;
  13. package body gsort is
  14.  
  15.   procedure put(v: vector) is
  16.   begin
  17.     for i in v'first..v'last loop
  18.       putaux(v(i));
  19.       put(' ');
  20.     end loop;
  21.     new_line;
  22.   end;
  23.  
  24.   procedure sort(v: in out vector) is
  25.     i: index;
  26.     j: index;
  27.     m: elem;
  28.     t: elem;
  29.   begin
  30.     i := v'first;
  31.     j := v'last;
  32.     m := v(index'val((index'pos(i)+index'pos(j))/2));
  33.     while i <= j loop
  34.       while gt(m, v(i)) loop
  35.     i := index'succ(i);
  36.       end loop;
  37.       while gt(v(j), m) loop
  38.     j := index'pred(j);
  39.       end loop;
  40.       if i <= j then
  41.     t := v(i);
  42.     v(i) := v(j);
  43.     v(j) := t;
  44.     i := index'succ(i);
  45.     j := index'pred(j);
  46.       end if;
  47.     end loop;
  48.     if v'first < j then
  49.       sort(v(v'first..j));
  50.     end if;
  51.     if i < v'last then
  52.       sort(v(i..v'last));
  53.     end if;
  54.   end sort;
  55.  
  56. end gsort;
  57.