program project1c (input, output, people, newfile);
type
      maxrange = 1..50;
      namestring = packed array [1..20] of char;
      inforec = packed record
                  name:       namestring;
                  qpa:        real;
                  numcrs:     integer;
                  courses:    packed array [1..10] of 0..4095;
              end;
      link = ^node;
      node = packed record
                    data:       inforec;
                    next:       link;
              end;
var
      students:   link;
      people:     file of inforec;
      newfile:    file of inforec;
      one:        inforec;
      command:    char;
      p, q:       link;

procedure locate (s: link; var nname: namestring;
                      var loc: link; var found: boolean);
var
      j:  integer;
      p, q: link;
begin
      nname := '                    ';
      j := 1;
      while (j <= 20) and (not eoln) do
      begin
          read (nname[j]);
          j := j + 1;
      end;
      readln;
      p := s^.next;
      q := s;
      while (p^.data.name < nname) and (p <> s) do
      begin
           q := p;
           p := p^.next;
      end;
      if p^.data.name = nname then found := true
      else found := false;
      loc := q;
end;

procedure add (var s: link);
var
      j:          integer;
      loc:        link;
      found:      boolean;
      newname:    namestring;
      w:          link;
begin
      write ('Enter name to add: ');
      locate (s, newname, loc, found);
      if not found then
      begin
          new(w);
          w^.data.name := newname;
          write ('Enter new qpa: ');
          readln (w^.data.qpa);
          write ('Enter number of courses: ');
          readln (w^.data.numcrs);
          write ('Enter ',w^.data.numcrs:1, ' course numbers: ');
          for j := 1 to w^.data.numcrs do
              read (w^.data.courses[j]);
          readln;
          w^.next := loc^.next;
          loc^.next := w;
          writeln (newname, ' added.');
      end
      else
          writeln (newname, ' is already in the database'); 
end;

procedure delete (var s: link);
var
      j:          integer;
      newname:    namestring;
      loc:        link;
      found:      boolean;
begin
      write ('Enter name to delete: ');
      locate (s, newname, loc, found);
      if found then
      begin
          loc^.next := loc^.next^.next;
          dispose(loc^.next);
          writeln (newname, ' deleted.');
      end
      else
          writeln (newname, ' is not in the database');
end;

procedure find (var s: link);
var
      c:          integer;
      newname:    namestring;
      loc,p:      link;
      found:      boolean;
begin
      write ('Enter name to find: ');
      locate (s, newname, loc, found);
      if found then
      begin
          p := loc^.next;
          writeln ('Name                 QPA   ', p^.data.numcrs:1,
                   ' Courses');
          with p^.data do
          begin
              write (name:20, qpa:5:2, '   ');
              for c := 1 to numcrs do
                  write (courses[c]:5);
              writeln;
          end;
      end
      else
          writeln (newname, ' is not in the database');
end;

procedure list (var s: link);
var
      j, c: integer;
      p:    link;
begin
      writeln ('Name                 QPA    #   Courses');
      p := s^.next;
      while p <> s do
      begin
          with p^.data do
          begin
              write (name:20, qpa:5:2, '  (', numcrs:1, ') ');
              for c := 1 to numcrs do
                  write (courses[c]:5);
              writeln;
          end;
          p := p^.next;
      end;
end;

procedure rank (var s:link);
type
      indexarray = packed array [maxrange] of link;
var
      ptr:        indexarray;
      j:          link;
      kt, k, m:   integer;
      exchange:   boolean;
begin
      exchange := true;
      j := s^.next;
      kt := 0;
      while j <> s do
      begin
           kt := kt + 1;
           ptr[kt] := j;
           j := j^.next;
      end;
      m := 1;
      while (m < kt) and exchange do
      begin
          exchange := false;
          for k := 1 to kt - m do
              if ptr[k]^.data.qpa < ptr[k+1]^.data.qpa then
              begin
                  j := ptr[k];
                  ptr[k] := ptr[k+1];
                  ptr[k+1] := j;
                  exchange := true;
              end;
          m := m + 1;
      end;
      writeln ('Rank order listing of students');
      writeln ('Name                  QPA');
      for k := 1 to kt do
          writeln (ptr[k]^.data.name, ptr[k]^.data.qpa:6:2);
      writeln;
end;

begin
      new(students);
      students^.data.name := 'zzzzzzzzzzzzzzzzzzzz';
      assign (people, 'l:\310\students.dat');
      reset (people);
      q := students;
      while not eof (people) do
      begin
          new(p);
          read (people, p^.data);
          q^.next := p;
          q := p;
      end;
      q^.next := students;
      writeln ('The commands for the database are  a - Add, d - delete, ',
                  'f - Find');
      writeln ('             l - List, r - Rank, and q - Quit');
      writeln;
      repeat
          write ('Enter command: ');
          readln (command);
          if (command <= 'Z') and (command >= 'A') then 
              command := chr (ord(command) + 32);
          case command of
          'a':    add (students);
          'd':    delete (students);
          'f':    find (students);
          'l':    list (students);
          'r':    rank (students);
          'q':    begin
                      close (people);
                      writeln;
                      writeln ('Student database closed');
                      assign (newfile, 'b:students.new');
                      rewrite (newfile);
                      p := students^.next;
                      while p <> students do
                      begin
                          write (newfile, p^.data);
                          p := p^.next;
                      end;
                      close (newfile);
                  end;
          '?':    begin
                      writeln ('The commands for the database are  ', 
                              'a - Add, d - delete, f - Find');
                      writeln ('             l - List, r - Rank, and q - Quit');
                      writeln;
                  end;
          else writeln ('Invalid command: ', command);
          end;
      until command = 'q';
end.