program DemonstrateHeapsort;
{$B-}
uses windos;
const MaxSize = 16000;

type  dataType = integer;
      heapType = array[1..MaxSize] of dataType;

procedure Adjust(var H : heapType; Root, Last : integer);
{ --------------------------------------------------------
  Converts a semiheap into a heap.
  Precondition: H is a semiheap rooted at position Root;
  Last marks the end of the semiheap. $B- is in effect.
  Postcondition: H is a heap rooted at position Root;
  Last marks the end of the heap.
  Method: Recursively trickles the item at position Root
  down to its proper position by swapping it with its larger
  child, if the child is larger than the item. If (2 * Root)
  > Last, the item is at a leaf and nothing needs to be done.
  -------------------------------------------------------- }
var	Child, RightChild : integer;
	Temp  : dataType;
begin
	if (2 * Root) <= Last
then	{ root is not a leaf }
begin
{ find index of larger child of root }
	Child := 2 * Root;         { index of root's left child }
	RightChild := succ(Child); { right child, if any}

	{ if there is a right child, find larger child }
	if (RightChild <= Last) and	(H[RightChild] > H[Child])
then Child := RightChild;
	{ Child is the index of larger child of root }

{ if the value at position Root is smaller than
  the value in the larger child, swap values }
	if H[Root] < H[Child]
then
begin
	{ swap }
	Temp := H[Root];
	H[Root] := H[Child];
	H[Child] := Temp;

	{ adjust the new subtree }
	Adjust(H, Child, Last)
end  { if }
end  { if }
{ if root is a leaf, do nothing }
end;  { Adjust }

procedure BuildHeap(var H : heapType; N : integer);
{ --------------------------------------------------------
  Builds the initial heap.
  Precondition: H is an array of N items.
  Postcondition: H is a heap of N items.
  -------------------------------------------------------- }
var Index : integer;
begin
	for Index := N downto 1 do
{ tree rooted at Index is a semiheap -
  transform it into a heap }
Adjust(H, Index, N)
end;  { BuildHeap }

procedure Heapsort(var A: heapType; N : integer);
{ --------------------------------------------------------
  Sorts an array by using heapsort.
  Precondition: A is an array of N items.
  Postcondition: A is sorted into ascending order.
  -------------------------------------------------------- }
var	Last : integer;
	Temp : dataType;
begin
	BuildHeap(A, N);{ build the initial heap }

	for Last := N downto 2 do	{ heapsort }
	{ loop invariant: A[1..Last] is a heap, A[Last+1..N] is
	  sorted and contains the largest elements of A }
	begin
{ swap A[1] and A[Last] }
Temp := A[1];
A[1] := A[Last];
A[Last] := Temp;

{ change semiheap into a heap }
Adjust(A, 1, pred(Last))
	end  { for }
end;  { Heapsort }

{ ******SAMPLE MAIN PROGRAM****** }
const Initialize = 870;

var  A : HeapType;
     N, Size : integer;
     Hour : word;
     Minute, Second : word;
     Sec100 : word;
     HeapSortOut: text;


begin
   { create an array of random integers }
  { Randomize;    }
   assign (HeapSortOut, 'a:HeapOut');
   rewrite (HeapSortOut);
   Randseed :=  Initialize;
   Size := MaxSize;
   for N := 1 to Size do
      A[N] := random(2000);
   writeln;
   writeln(HeapSortOut);
   writeln('This is a Heap Sort with an array size of', MaxSize:8, ' elements');
   writeln(HeapSortOut,'This is a Heap Sort with an array size of', MaxSize:8, ' elements');
   writeln('The array before sorting is: ');
   writeln(HeapSortOut, 'The array before sorting is: ');
   for N := 1 to 10 do
     begin
        write(A[N]:6);
        write(HeapSortOut, A[N]:6);
     end;
   writeln;
   writeln (HeapSortOut);
   gettime (Hour, Minute, Second, Sec100);
   writeln ('Start Time: ',Hour, 'Hour ':6, Minute, 'Minute ':8, Second,'Second ':9,
            Sec100,' Hundredths of seconds ':14);
   writeln (HeapSortOut,'Start Time: ',Hour, 'Hour ':6, Minute, 'Minute ':8, Second,'Second ':9,
            Sec100,' Hundredths of seconds ':14);

   { sort the array }
   HeapSort(A, Size);
   gettime (Hour, Minute, Second, Sec100);
   writeln ('End   Time: ',Hour, 'Hour ':6, Minute, 'Minute ':8, Second,'Second ':9,
            Sec100,' Hundredths of seconds ':14);
   writeln (HeapSortOut,'End   Time: ',Hour, 'Hour ':6, Minute, 'Minute ':8, Second,'Second ':9,
            Sec100,' Hundredths of seconds ':14);
   writeln('The array after sorting is: ');
   writeln(HeapSortOut,'The array after sorting is: ');
   for N := 1 to 15 do
     begin
        write(A[N]:4);
        write(HeapSortOut, A[N]:4);
     end;

   close (HeapSortOut);
end.

   program tree;
    uses crt;
     type pwl=^din; st=string[20];
          din= record
                  inf:st;
                  left,right,top:pwl;
               end;
      var root,ed,rab,tek,pred:pwl;
          f:text;
          i,n:integer;
          b,ex:boolean;
          a:st;
//--------MR----------------------------------
 Function mr(one,two:st):boolean;
  var i,n:integer;
      ex:boolean;
  begin
   if length(one)<length(two) then n:=length(one) else n:=length(two); i:=1; ex:=true;
   while ex do
     if  one[i]<two[i] then
      begin
       mr:=true;
       ex:=false; inc(i);
      end
       else if one[i]>two[i] then
        begin
         mr:=false;
         ex:=false; inc(i);
        end else begin ex:=true;  inc(i); end;

  end;
//-------mr end-----------------------------------
BEGIN clrscr;
   assign(f,'inp.txt');
   reset(f);
   readln(f,n);
// ====Root==================================
    new(root);
    new(ed);
   with ed^ do
     begin
      left:=nil;
      right:=nil;
      top:=nil
     end;

     With root^ do
        begin
         readln(f,inf);
         top:=ed;
         left:=nil;
         right:=nil;
        end;
//===Root==================================

//============================================

//==============Writing in tree begin=======================================
 {for i:=1 to n-1 do}
  while not eof(F) do 
  BEGIN
    tek:=root;
    ex:=true;
     while ex do
       begin
         readln(f,a);
         if mr(a,tek^.inf) and (tek^.left=nil)
          then
           begin
            new(rab);
             with rab^ do
              begin
               readln(f,inf);
               left:=nil;
               right:=nil;
               top:=tek;
              end;
              tek^.left:=rab;
              ex:=false;
            end
           else if mr(a,tek^.inf)=false  and (tek^.right=nil)
            then
             begin
              new(rab);
               with rab^ do
                begin
                 readln(f,a);
                 left:=nil;
                 right:=nil;
                 top:=tek;
                end;
              tek^.right:=rab;
              ex:=false;
             end
            else if mr(a,tek^.inf)
             then tek:=tek^.left
             else tek:=tek^.right;
       end;
  END;
//=======================Writing in tree end====================================

//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//=======================Reading in tree begin=================================
 tek:=root;
 i:=0;



 while tek^.left<>nil do
   tek:=tek^.left;
 while tek^.top<>nil do
  BEGIN
   if tek^.right<>nil
    then
     tek:=tek^.right
    else
     if tek^.left<>nil
      then
       tek:=tek^.left
      else
       begin
        writeln(tek^.inf);
        rab:=tek;
        tek:=tek^.top;
        dispose(rab);
         with tek^ do
          begin
           left:=nil;
           right:=nil;
          end;
       end;
    END;
//==================Reading tree end=====================================



readln;


END.