program heap_sort;
uses crt;

type  worte = string[50];
const  maxN = 250;

var a   : array[1..maxN] of worte;
    h   : array[0..maxN] of worte;     (* der Heap *)
    L,N,M : integer;   (* Anzahl der eingegeben WÖrter *)


procedure lies_strings;
var i : integer;
begin
 i:=0;
 repeat
   i:=i+1;
   write('Wort ',i,'  :  ');  readln(a[i]);
 until a[i]='';
 a[i]:='                                              ';
 L:=i-1;
end;


procedure lies_strings_von_datei(datei : string);
var dat : text;
    i   : word;
begin
 i:=0;
 assign(dat,datei);
 reset(dat);
 if not eof(dat) then
   repeat
    i:=i+1;
    readln(dat,a[i]);
   until eof(dat);
 L:=i;
 a[i+1]:='                                         ';
 close(dat);
end;

procedure print_strings( ab:integer);
var i : integer;
begin
 for i:=ab to L do  writeln(a[i]);
 writeln('*** ende *** ');
end;


procedure print_sortet_strings( ab:integer);
var i : integer;
begin
 for i:=ab to M do  writeln(H[i]);
 writeln('*** ende *** ');
end;


procedure upheap(k :integer);
var v : worte;
begin
 v:=H[k];
 while H[k div 2] <= v do
   begin  H[k]:=H[k div 2]; k:=k div 2;  end;
 H[k]:=v;
end;


procedure downheap( k:integer);
label 0;
var j : integer;
    v : worte;
begin
  v:=H[k];
  while k<=N div 2 do
   begin
     j:=k+k;
     if j<N then if H[j]<H[j+1] then j:=j+1;
     if v>=H[j] then goto 0;
     H[k]:=H[j];
     k:=j;
   end;
0: H[k]:=v;
end;


procedure create_heap;
var i : integer;
begin
 H[0]:='Þ';           (* Maximum *)
 for i:=1 to L do
   begin
     H[i]:=a[i];
     upheap(i);
   end;
 M:=L;
 H[M+1]:='                                      ';
end;


procedure heapsort;
var k : integer;
    t : worte;
begin
 N:=M;
 repeat
   t:=H[1];  H[1]:=H[N];  H[N]:=t;
   N:=N-1;
   downheap(1);
 until N<=1;
end;



(*************************** Main ***********************)
begin
 clrscr;
 lies_strings_von_datei('sorting.asc');
 print_strings(1);  writeln;writeln; readln;
 create_heap;
 heapsort;
 print_sortet_strings(1);  readln;
end.