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.