{$debug-}

program sort (output,infile,outfile);

function allhqq (size: word) : word;
  external;
  
procedure endxqq;
  external;

var
  infile, outfile : text;
  p               : array [wrd(1)..4000] of adrmem;
  ptr             : adrmem;
  inline          : lstring (255);
  max_p           : word;
  lines_in        : word;
  
procedure read_in;
  var [static]
    i      : word;
    offwrd : word;
    offadr : adrmem;
    inladr : adrmem;
  begin
    inladr := adr inline;
    write   ('Reading...     ');
    reset (infile);
    lines_in := 0;
    while not eof (infile) do
      begin
        readln (infile,inline);
        if inline.len >  80 then
           inline.len := 80;
        for i := inline.len downto 1 do
          if inline [i] = ' ' then
            inline.len := inline.len - 1
          else
            break;
        lines_in := lines_in + 1;
        write (chr(8),chr(8),chr(8),chr(8),chr(8),lines_in:5);
        offwrd   := allhqq (inline.len + 1);
        offadr   := retype (adrmem,offwrd);
        if (offwrd < 2) or (lines_in > 4000) then
          begin
            lines_in := lines_in - 1;
            writeln;
            writeln ('Error! Too many index lines to sort in memory, ',
                     'sorting only the first',lines_in:5);
            writeln;
            return;
          end;
        p [lines_in] := offadr;
        for i := 0 to inline.len do
          offadr^[i] := inladr^[i];        
      end;
    close (infile);
    writeln (' index entries read.');
  end;
  
procedure sort_data;
  var [static]
    done : boolean;
    i    : word;
    j    : word;
    last : word;
    pass : word;
    w    : integer;
    
    function to_switch : boolean;
      var [static]
        ii,jj : lstring (80);
        ip,jp : adrmem;
        k     : word;
        last  : word;
        temp  : byte;
      begin
        if i = 1 then
          begin
            ip := p [i];
            ii.len := ip^[0];
            for k := 1 to ii.len do
              begin
                temp := ip^[k];
                if temp < 91 then
                  if temp > 64 then
                    temp := temp + 32;
                ii [k] := chr (temp);
              end;
          end;
        jp := p [j];
        jj.len := jp^[0];
        for k := 1 to jj.len do
          begin
            temp := jp^[k];
            if temp < 91 then
              if temp > 64 then
                temp := temp + 32;
            jj [k] := chr (temp);
          end;
        if ii.len > jj.len then
          last := jj.len
        else
          last := ii.len;
        if last < 8 then
          begin
            to_switch := false;
            ii := jj;
            return;
          end;
        for k := 8 to last do
          begin
            if ii [k] < jj [k] then
              begin
                to_switch := false;
                ii := jj;
                return;
              end;
            if ii [k] > jj [k] then
              begin
                to_switch := true;
                return;
              end;
          end;
        if ii.len > jj.len then
          begin
            to_switch := true;
            return;
          end;
        if ii.len < jj.len then
          begin
            to_switch := false;
            ii := jj;
            return;
          end;
        for k := 1 to 6 do
          begin
            if ii [k] < jj [k] then
              begin
                to_switch := false;
                ii := jj;
                return;
              end;
            if ii [k] > jj [k] then
              begin
                to_switch := true;
                return;
              end;
          end;
        to_switch := false;
        ii := jj;
      end;
          
  begin
    if lines_in < 2 then
      return;
    write   ('Sorting...     ');
    last := lines_in;
    pass := 0;
    repeat
      pass := pass + 1;
      write (chr(8),chr(8),chr(8),chr(8),chr(8),pass:5);
      last := last - 1;
      done := true;
      for i := 1 to last do
        begin
          j := i + 1;
          if to_switch then
            begin
              done  := false;
              ptr   := p [i];
              p [i] := p [j];
              p [j] := ptr;
            end;
        end;
    until done;
    writeln (' sorting passes made.');
  end;
  
procedure write_out;
  var [static]
    i : word;
    j : word;
  begin
    write   ('Writing...     ');
    rewrite (outfile);
    for i := 1 to lines_in do
      begin
        write (chr(8),chr(8),chr(8),chr(8),chr(8),i:5);
        ptr := p [i];
        inline.len := ptr^[0];
        for j := 1 to inline.len do
          inline [j] := chr(ptr^[j]);
        writeln (outfile,inline);
      end;
    close (outfile);
    writeln (' lines written.');
  end;

procedure initialize;
  begin
    writeln;
    writeln ('Index sorting program, (C) Copyright Peter Norton 1983');
    writeln;
  end;
  
begin
  initialize;
  read_in;
  sort_data;
  write_out;
end.