Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB11.ZIP/GRADES.PAS

Pascal/Delphi Source File | 1986-01-02 | 45.5 KB | 1,928 lines

PROGRAM GRADES;

CONST
  MAXRECORDS = 101;
  MAXSIZE    = 100;      (*MAXSIZE := MAXRECORDS - 1*)
  NAMESIZE   = 20;
  headsize   = 50;
  COMSIZE    = 40;

TYPE
  diskstring  = string[2];
  stringtype  = string [NAMESIZE];
  setofchar   = set of char;
  commandtype = string [COMSIZE];

  gradeptr = ^gradetype;
    gradetype = record
      title : stringtype;
      grade : real;
      ptr   : gradeptr;
    end; (*gradetype*)


  STUDENTTYPE = record
    name   : stringtype;
    hmwk   : gradeptr;
    quiz   : gradeptr;
    test   : gradeptr;
    lab    : gradeptr;
    final  : real;
    ave    : real;
    fptr   : integer;
    bptr   : integer;
  end; (*classtype*)

  STUDENTLIST = array [0 .. MAXSIZE] of STUDENTTYPE;

  link = ^hashstructure;
    hashstructure = record
      pos : integer;
      ptr : link;
    end;

  HASHTYPE = array [0 .. MAXSIZE] of link;

VAR
  STUDENT       : STUDENTLIST ;
  HASH          : HASHTYPE;
  EMPTY,p,y     : INTEGER;
  header        : string[headsize];
  drive         : diskstring;
  file_out      : boolean;
  f             : TEXT;
  name          : stringtype;
  okset,nameset : setofchar;
  beep          : char;

(******************************** INITIALIZE *******************************)

PROCEDURE INITIALIZE;

var
  i,j : integer;

begin
  for i := 0 TO MAXSIZE do begin
    with STUDENT [i] do begin
      name := '[';
      hmwk   := nil;
      quiz   := nil;
      test   := nil;
      lab    := nil;
      final  := 0;
      fptr   := i+1;
      bptr   := 0;
    end; (*with*)

    hash [i] := nil;
  end; (* for i *)

  STUDENT [MAXSIZE].fptr := 0;
  STUDENT [0].fptr := 0;
  STUDENT [0].name := 'total pts: ';
  EMPTY := 1;
end; (*initialize*)

{--------------------------------------}
procedure video (i : integer);
begin
  textcolor (i);
end; { video }

{--------------------------------------}
function getchar (okset : setofchar):char;
var
  c : char;

begin
  read (kbd,c);
  c := UpCase (c);
  if not (c in okset) then write (beep)
    else if c in [' '..'}'] then write (c);

  while not (c in okset) do begin
    read (kbd,c);
    c := UpCase (c);
    if not (c in okset) then write (beep)
      else if (c in [' '..'}']) then write (c);
  end;  { while not good }
  getchar := c;
end;  { getchar }

{--------------------------------------}
procedure getname (var s : stringtype; okset : setofchar);
var
  i     : integer;
  s1    : string[1];
  stemp : stringtype;

begin
  s1 := ' ';
  stemp := '';
  s1[1] := getchar (okset + [#13]);
  if s1[1] in okset then stemp := concat (stemp,s1);
  while (s1[1]<>#13) and (length(stemp)<NAMESIZE) do begin
    if length(stemp)=0 then s1[1] := getchar (okset + [#13])
    else if length(stemp)=NAMESIZE then s1[1] := getchar ([#13,#8])
      else s1[1] := getchar (okset + [#13,#8]);

    if s1[1] in okset then stemp := concat (stemp,s1)
      else if s1[1]=#8 then begin
        write (chr(8),' ',chr(8));
        delete (stemp,length(stemp),1);
      end  { else }
  end; { while }

  if length(stemp)>0 then begin
    s := stemp;
    for i := (length(stemp)+1) to NAMESIZE do  s := concat(s,'.');
  end
  else write (s);
end;

{--------------------------------------}
procedure getpaper (var s : stringtype; okset : setofchar);
var
  i     : integer;
  s1    : string[1];
  stemp : stringtype;

begin
  s1 := ' ';
  stemp := '';
  s1[1] := getchar (okset + [#13]);
  if s1[1] in okset then stemp := concat (stemp,s1);
  while (s1[1]<>#13) and (length(stemp) < NAMESIZE) do begin
    if length(stemp)=0 then s1[1] := getchar (okset + [#13])
    else if length(stemp)=NAMESIZE then s1[1] := getchar ([#13,#8])
      else s1[1] := getchar (okset + [#13,#8]);

    if s1[1] in okset then stemp := concat (stemp,s1)
      else if s1[1]=#8 then begin
        write (chr(8),' ',chr(8));
        delete (stemp,length(stemp),1);
      end  { else }
  end; { while }

  if length(stemp)>0 then begin
    s := stemp;
    for i := (length(stemp)+1) to NAMESIZE do  s := concat(' ',s);
  end
  else write (s);
end;

{--------------------------------------}
procedure getstring (var s : stringtype; okset : setofchar);
var
  i     : integer;
  s1    : string[1];
  stemp : stringtype;

begin
  s1 := ' ';
  stemp := '';
  s1[1] := getchar (okset + [#13]);
  if s1[1] in okset then stemp := concat (stemp,s1);
  while s1[1]<>#13 do begin
    if length(stemp)=0 then s1[1] := getchar (okset + [#13])
    else if length(stemp)=80 then s1[1] := getchar ([#13,#8])
      else s1[1] := getchar (okset + [#13,#8]);

    if s1[1] in okset then stemp := concat (stemp,s1)
      else if s1[1]=#8 then begin
        write (chr(8),' ',chr(8));
        delete (stemp,length(stemp),1);
      end  { else }
  end; { while }

  if length(stemp)>0 then s := stemp
    else write (s);
end;

{--------------------------------------}
procedure getint (com : commandtype; var int : integer);
var
  s        : stringtype;
  i,result : integer;

begin
  okset := (['-'] + ['0'..'9']);
  repeat
    write (com);
    s := ''; result := 0;
    getstring (s,okset);
    if length(s)>0 then begin
      val (s,i,result);
      if result<>0 then begin video (30);
        write (beep,' integer expected '); delay (2000); video (15);
        delLine; clreol;
      end; { if result <>0 }
    end; {if length (s) >0 }
  until result=0;

  if length(s)>0 then int := i
    else write (int);
end; { getint }

{--------------------------------------}
procedure getreal (com : commandtype; var rl : real);
var
  r         : real;
  result    : integer;
  s         : stringtype;

begin
  okset := (['-','.'] + ['0'..'9']);
  repeat
    write (com);
    s := ''; result := 0;
    getstring (s,okset);
    if length(s)>0 then begin
      val (s,r,result);
      if result<>0 then begin video (30);
        write (beep,' real expected '); delay (2000); video (15);
        delLine; clreol;
      end; { if result <>0 }
    end; { if length(s) >0 }
  until result=0;

  if length(s)>0 then rl := r
    else write (rl);
end; { getreal }

{--------------------------------------}
function yes : boolean;
var
  c : char;

begin
  c := getchar (['Y','N']);
  if c='Y' then yes := true
    else yes := false;
end; { yes }

(********************************* COMPARE *********************************)

(* COMPARE =
     -1 if term1 < term2
      0 if term1 = term2
      1 if term1 > term2
*)

FUNCTION COMPARE (term1,term2 : stringtype):integer;
begin
  if (term1 > term2) then compare := 1
    else if (term1 < term2) then compare := -1
    else compare := 0;
end; (* compare*)

(******************************* HASHID ************************************)

FUNCTION HASHNAME (term : stringtype):integer;

var
  i,key : integer;

begin
  key := 0;
  for i := 1 to length(term) do key := key + ord (term[i]);
  HASHNAME := trunc (MAXRECORDS * (key * 0.618034 - trunc (key*0.618034)));
end; (*hash*)

(****************************** INSERTHASH *********************************)

PROCEDURE INSERTHASH (i : integer);

var
  j : integer;
  p : link;

begin
  j := HASHNAME (STUDENT [i].name);
  new (p);
  p^.pos   := i;
  p^.ptr   := HASH [j];
  HASH [j] := p;
end; (* INSERTHASH *)

(******************************** INSERT ***********************************)

PROCEDURE INSERT (i : integer);

var
  j : integer;

begin
  j     := STUDENT [0].fptr;

  while (COMPARE (STUDENT [j].name,STUDENT [i].name) <1) do
    if (COMPARE (STUDENT [j].name,STUDENT [i].name) =0) then begin
      writeln; video (30);
      writeln (beep,'Student already entered');
      writeln ('Addition of name aborted');
      video (15); delay (2000);
      exit;
    end
    else
      j := STUDENT [j].fptr;

  EMPTY := STUDENT [i].fptr;
  STUDENT [i].bptr := STUDENT [j].bptr;
  STUDENT [i].fptr := STUDENT [STUDENT [j].bptr].fptr;
  STUDENT [STUDENT [j].bptr].fptr := i;
  STUDENT [j].bptr := i;

  INSERTHASH (i);
end; (* insert *)

(****************************** ADDNAME ************************************)

PROCEDURE ADDNAME;

var
  i : integer;

begin
  clrscr;
  i := EMPTY;
  if i=0 then begin
    writeln; video (30);
    writeln (beep,'Maximum number of students already entered');
    writeln ('Check manual for directions');
    video(15); delay(2000);
  end

  else with STUDENT [i] do begin
    writeln;
    write ('Enter student name: ');
    name := '';
    getname (name,nameset);
    if (length(name)>0) then insert (i)
      else name := '[';
  end; (*else*)
end; (*addname*)

(********************************* ENTERCLASS ****************************)

PROCEDURE ENTERCLASS;

var
  i,num : integer;

begin
  clrscr;
  num := 0;
  getint ('Number of students to be entered: ',num);
  for i := 1 to num do
    ADDNAME;
end; (* enterclass *)

(******************************* FINDNAME *******************************)

PROCEDURE FINDNAME (term : stringtype;
                    var found : boolean;
                    var p,q   : link;
                    var j : integer);

begin
  j := HASHNAME (term);

  found := false;
  q     := nil;
  p     := HASH [j];

  while (p<>nil) and not found do
    if (COMPARE (STUDENT [p^.pos].name,term) = 0) then
      found := true
    else begin
      q := p;
      p := p^.ptr;
    end; (*else*)
end; (* findname *)

(********************************* CHANGENAME ***************************)

PROCEDURE CHANGENAME;

var
  term : stringtype;
  i,j  : integer;
  found: boolean;
  p,q  : link;

begin
  clrscr;
  write ('Change which name? ');
  term := '';
  getName (term,nameset);
  FindName (term,found,p,q,i);

  if not found then begin
    video (30); writeln;
    writeln (beep,term,' not found in class list');
    video(15); delay (2000);
  end

  else begin
    j := p^.pos;
    if q=nil then
      HASH [i] := p^.ptr
    else
      q^.ptr := p^.ptr;

    writeln; writeln;
    write ('Change name to? ');
    getname (STUDENT [j].name,nameset);

    i := STUDENT [0].fptr;
    while (COMPARE (STUDENT [i].name,STUDENT [j].name)<1) and (i<>0) do
      i := STUDENT [i].fptr;

    STUDENT [STUDENT [j].bptr].fptr := STUDENT [j].fptr;
    STUDENT [STUDENT [j].fptr].bptr := STUDENT [j].bptr;
    STUDENT [j].bptr := STUDENT [i].bptr;
    STUDENT [j].fptr := STUDENT [STUDENT [i].bptr].fptr;
    STUDENT [STUDENT [i].bptr].fptr := j;
    STUDENT [i].bptr := j;

    INSERTHASH (j);
  end; (* else *)
end; (* changename *)

(********************************** DELNAME *****************************)

PROCEDURE DELNAME;

var
  i,j   : integer;
  found : boolean;
  term  : stringtype;
  p,q   : link;

begin
  clrscr;
  write ('Delete which student? ');
  term := '';
  getname (term,nameset);

  FINDNAME (term,found, p,q,j);

  if not found then begin
    writeln; video (30);
    writeln (beep,term,' not in classlist - no deletion performed!');
    delay (2000); video (15);
  end (* if *)

  else begin
    if q=nil then
      HASH [j] := nil
    else
      q^.ptr := p^.ptr;

    i := p^.pos;
    STUDENT [STUDENT [i].bptr].fptr := STUDENT [i].fptr;
    STUDENT [STUDENT [i].fptr].bptr := STUDENT [i].bptr;
    STUDENT [i].fptr := EMPTY;
    STUDENT [i].name := '[';
    dispose (p);
    EMPTY := i;
  end; (* else *)
end; (* DELNAME *)

(*********************************** FindPaper **************************)

PROCEDURE FindPaper (var p,q   : gradeptr;
                           j   : stringtype;
                     var found : boolean);

begin
  found := false;
  q     := nil;

  while (p<>nil) and not found do
    if (COMPARE (p^.title,j) <> 0) then begin
      q := p;
      p := p^.ptr;
    end
    else found := true;
end; (* findpaper *)

(********************************** InsertGrade **************************)

PROCEDURE InsertGrade (var p,q,s : gradeptr;
                           i,l   : integer;
                           j     : stringtype);

(* input parameters -
     p - pointer from FindPaper
     i - array position of student
     j - title of paper*)

var
  g     : real;
  found : boolean;

begin
  with STUDENT [i] do begin
    FindPaper (p,q,j,found);
    g := p^.grade;
    if l=1 then writeln (name,' ',g:4:1);
    getreal (concat(name,' '),g);

    if found then begin
      s := p;
      if (p^.grade=0) or (g>0) then
        p^.grade := g
    end
    else begin
      new (s);
      s^.title := j;
      s^.grade := g;
      s^.ptr   := p;
    end; (* else *)
  end; (* with *)
end; (* InsertGrade *)

(*********************************** SETGRADE **************************)

PROCEDURE SETGRADE (i,l   : integer;
                    j     : stringtype;
                    var r : gradeptr);

var
  p,q,s : gradeptr;

begin
  with STUDENT [i] do begin
    p := r;
    InsertGrade (p,q,s,i,l,j);

    if q=nil then
      r := s
    else
      q^.ptr := s;

  end; (* with *)
end; (* setgrade *)

(****************************** GRADEMENU ********************************)

FUNCTION GRADEMENU:char;
begin
  clrscr;
  writeln ('Select type of paper from list');
  writeln;
  writeln ('  H -- homework');
  writeln ('  Q -- quiz');
  writeln ('  L -- lab');
  writeln ('  E -- hour exam');
  writeln ('  F -- final exam');
  writeln ('<cr>-- return to main menu');
  writeln;
  write ('Enter selection: ');
  GRADEMENU := getchar (['H','Q','L','E','F',#13]);
end; (*grademenu*)

(********************************* ENTERGRADE ***************************)

PROCEDURE ENTERGRADE (i : integer; k : char;
                      j   : stringtype;
                      l : integer);

begin
  with STUDENT [i] do
    case k of
      'H' : SETGRADE (i,l,j,hmwk);

      'Q' : SETGRADE (i,l,j,quiz);

      'L' : SETGRADE (i,l,j,lab);

      'E' : SETGRADE (i,l,j,test);

      'F' : begin
              writeln;
              final := 0;
              getreal (concat(name,' '),final);
            end;
    end; (*case*)
end; (* entergrade *)

(********************************** GetGrade ****************************)

FUNCTION GetGrade (i : integer; k : char;
                     j : stringtype):real;

var
  p,q   : gradeptr;
  found : boolean;

begin
  with STUDENT [i] do
    case k of
      'H' : begin
              p := hmwk;
              FindPaper (p,q,j,found);
              if not found then
                GetGrade := -1
              else
                GetGrade := p^.grade;
            end;

      'Q' : begin
              p := quiz;
              FindPaper (p,q,j,found);
              if not found then
                GetGrade := -1
              else
                GetGrade := p^.grade;
            end;

      'L' : begin
              p := lab;
              FindPaper (p,q,j,found);
              if not found then
                GetGrade := -1
              else
                GetGrade := p^.grade;
            end;

      'E' : begin
              p := test;
              FindPaper (p,q,j,found);
              if not found then
                GetGrade := -1
              else
                GetGrade := p^.grade;
            end;
      'F' : GetGrade := final;
    end; (* case *)
end; (* GetGrade *)

(******************************** PUTINCLASS ******************************)

PROCEDURE PUTINCLASS;

var
  i,t : integer;
  j   : stringtype;
  c   : char;

begin
  c := GRADEMENU;
  clrscr;

  if c<>#13 then begin

    if c<>'F' then begin
      write ('Title of paper: '); j := '';
      getpaper (j,nameset+['0'..'9']); writeln;
    end (* if *)

    else j := 'Final Exam';

    t := trunc (GetGrade (0,c,j));
    if (t<=0) then
      repeat
        ENTERGRADE (0,c,j,0);
        t := trunc (GetGrade (0,c,j));
        if t=0 then
          writeln ('Total cannot be zero -- try again');
      until (t>0)
    else with STUDENT [0] do
      writeln (name,t);

    i := STUDENT [0].fptr;
    repeat
      writeln;
      ENTERGRADE (i,c,j,0);
      i := STUDENT [i].fptr;
    until i=0;
  end; (* if *)
end; (* putinclass *)

(********************************** ENTERPERSON ****************************)

PROCEDURE ENTERPERSON;

var
  i,t    : integer;
  x,z    : link;
  found  : boolean;
  j,term : stringtype;
  c      : char;

begin
  clrscr;
  write ('Which student? '); term := '';
  getname (term,nameset);
  FindName (term,found,x,z,i);

  if not found then begin
    writeln; video(30);
    writeln (beep,'Student not found'); video(15); delay(2000);
  end (* if *)

  else begin
    i := x^.pos;
    c := GRADEMENU;
    clrscr;

    if c<>#13 then begin
      if c<>'F' then begin
        write ('Title of paper: '); j := '';
        getpaper (j,(nameset + ['0'..'9']));
      end; (* if *)

      t := trunc (GetGrade (0,c,j));

      if t=-1 then begin
        video(30); writeln;
        writeln ('Paper not in file ');
        video(15); delay(2000);
      end
      else
        writeln;
        ENTERGRADE (i,c,j,1);
    end; (* if *)
  end; (* else *)
end; (* enterperson *)

(********************************* REMOVE ********************************)

PROCEDURE REMOVE;

var
  p,q     : gradeptr;
  i       : integer;
  term    : stringtype;
  found   : boolean;
  c       : char;

begin
  c := GRADEMENU;
  clrscr;
  write ('Remove which paper? ');
  getpaper (term,nameset);

  i := 0;
  repeat
    with STUDENT [i] do begin
      case c of
        'H': begin
               p := hmwk;
               FindPaper (p,q,term,found);
               if found then begin
                 if q=nil then
                   hmwk := p^.ptr
                 else
                   q^.ptr := p^.ptr;
                 dispose (p);
               end;
             end;
        'Q': begin
               p := quiz;
               FindPaper (p,q,term,found);
               if found then begin
                 if q=nil then
                   quiz := p^.ptr
                 else
                   q^.ptr := p^.ptr;
                 dispose(p);
               end;
             end;
        'L': begin
               p := lab;
               FindPaper (p,q,term,found);
               if found then begin
                 if q=nil then
                   lab := p^.ptr
                 else
                   q^.ptr := p^.ptr;
                 dispose (p);
               end;
           end;
        'E': begin
               p := test;
               FindPaper (p,q,term,found);
               if found then begin
                 if q=nil then
                   test := p^.ptr
                 else
                   q^.ptr := p^.ptr;
                 dispose (p);
               end;
           end;
      end; (* case *)
      i := fptr;
    end; (* with *)
  until (i=0);
  if not found then begin
    writeln; video(30);
    writeln (beep,term,' not found');
    delay (2000); video(15);
  end; (* if *)
end; (* remove *)

(********************************** WHO **********************************)

PROCEDURE WHO;
var
  c : char;

begin
  clrscr;
  writeln ('Do you wish to:');
  writeln;
  writeln ('  C -- Enter entire class');
  writeln ('  I -- Change individual grade');
  writeln ('  R -- Remove paper');
  writeln ('<cr>-- Return to main menu');
  writeln;
  write ('Enter choice: ');
  c := getchar (['C','I','R',#13]);

  case c of
    'C' : PUTINCLASS;
    'I' : ENTERPERSON;
    'R' : REMOVE;
  end; (*case*)
end; (*who*)

(********************************* PRINTGRADES ****************************)

PROCEDURE PRINTGRADES (i : integer; var p,q : gradeptr; one : boolean);

var
  a,t : real;

begin
  a := 0;
  t := 0;

  if q = nil then
    t := 1;

  while (q<>nil) do begin
      t := q^.grade + t;
      q := q^.ptr;
    end;

  with STUDENT [i] do
    write (f,name:20);

  while (p<>nil) do begin
    if one then begin
      writeln(f);
      write (f,p^.title);
    end; (* if *)

    a := a + p^.grade;
    write (f,p^.grade:5:1);
    p := p^.ptr;

    if p=nil then
      writeln (f,'   ave : ',(a*100/t):5:1);
  end; (* while *)
end; (* printgrades *)

(********************************* PRINTSTUDENT ****************************)

PROCEDURE PRINTSTUDENT (i : integer; c : char; one : boolean);
var
  p,q : gradeptr;

begin
  with STUDENT [i] do begin
    case c of
      'H': begin
             p := hmwk;
             q := STUDENT [0].hmwk;
             PRINTGRADES (i,p,q,one);
           end;

      'Q' : begin
              p := quiz;
              q := STUDENT [0].quiz;
              PRINTGRADES (i,p,q,one);
            end;

      'L' : begin
              p := lab;
              q := STUDENT [0].lab;
              PRINTGRADES (i,p,q,one);
            end;

      'E' : begin
              q := STUDENT [0].test;
              p := test;
              PRINTGRADES (i,p,q,one);
            end;

      'F' : writeln (f,name,(100*final/STUDENT [0].final):5:1);
    end; (* case *)
  end; (* with *)
end; (* printstudent *)

(********************************** TITLES *********************************)

PROCEDURE TITLES (q : gradeptr);

var
  p : gradeptr;
  i : integer;

begin
  for i := 1 to NAMESIZE do begin
    write (f,'                   ');
    p := q;
    while p<>nil do begin
      write (f,'    ',p^.title [i]);
      p := p^.ptr;
    end; (* while *)
    writeln(f);
  end; (* for *)

  writeln(f);
  with STUDENT [0] do begin
    write (f,name:20);
    p := q;
    while p<>nil do begin
      write (f,p^.grade:5:1);
      p := p^.ptr;
    end; (* while *)
  end; (* with *)

  writeln (f);
  writeln (f,'-------------------------------------------------------------------------');
end; (* titles *)

(********************************* PRINTCLASS *****************************)

PROCEDURE PRINTCLASS;
var
  i : integer;
  c : char;

begin
  c := GRADEMENU;
  clrscr;

  if c<>#13 then begin
    case c of
      'H' : TITLES (STUDENT [0].hmwk);
      'Q' : TITLES (STUDENT [0].quiz);
      'L' : TITLES (STUDENT [0].lab);
      'E' : TITLES (STUDENT [0].test);
    end; (* case *)

    i := STUDENT [0].fptr;
    repeat
      with STUDENT [i] do begin
        PRINTSTUDENT (i,c,false);
        i := fptr;
        if (i mod(15) = 0) then begin
          writeln; write ('To continue press return'); readln;
          y := wherey-2; gotoxy (1,y);
        end;
      end; (* with *)
    until (i=0);
  end; (* if *)
end; (* printclass *)

(******************************** PRINTPERSON ***************************)

PROCEDURE PRINTPERSON;

var
  i     : integer;
  p     : gradeptr;
  x,z   : link;
  found : boolean;
  term  : stringtype;
  c     : char;

begin
  clrscr;
  write ('Which student? ');
  term := '';
  getname (term,nameset);
  FindName (term,found,x,z,i);
  if not found then begin
    video (30); writeln;
    writeln (beep,term,' not in class list');
    video (15); writeln;
  end

  else begin
    i   := x^.pos;
    c   := GRADEMENU;
    if c<>#13 then begin
      clrscr;
      PRINTSTUDENT (i,c,true);
    end; (* if *)
  end; (* else *)
  writeln; write ('To continue press return'); readln;
end; (* printperson *)

(********************************* EXAMINE *******************************)

PROCEDURE EXAMINE;
var
  j   : integer;
  p   : gradeptr;
  c   : char;

  procedure title;

  begin
    with STUDENT [j] do
      while p<>nil do begin
        writeln (f,p^.title,'--------',p^.grade:5:1);
        p := p^.ptr;
      end; (* while *)
  end; (* title *)

begin
  clrscr;
  writeln ('Do you wish to see:');
  writeln;
  writeln ('  N -- student names');
  writeln ('  H -- homework titles');
  writeln ('  Q -- quiz titles');
  writeln ('  L -- lab titles');
  writeln ('<cr>-- return to main menu');
  writeln;
  write ('Enter choice: ');
  c := getchar (['N','H','Q','L',#13]);

  clrscr;
  j := 0;
  case c of
    'N' : begin
          writeln (f,'STUDENT':10);
          j := STUDENT [0].fptr;
          repeat
            writeln (f,STUDENT [j].name);
            j := STUDENT [j].fptr;
          until (j=0);
        end;

    'H' : begin
          writeln (f,'HOMEWORK TITLES     TOTAL POINTS');
          p := STUDENT [j].hmwk;
          title;
        end;

    'Q' : begin
          writeln (f,'QUIZ TITLES         TOTAL POINTS');
          p := STUDENT [j].quiz;
          title;
        end;

    'L' : begin
          writeln (f,'LAB TITLES          TOTAL POINTS');
          p := STUDENT [j].lab;
          title;
        end;
  end; (* case *)
  writeln; write ('To continue press return'); readln;
end; (* examine *)

{--------------------------------------}
{
Source: "TIMESTAMP and KBIN for the IBM-PC", TUG Lines Volume I Issue 2
Author: Karl Gerhard
Date:   7/5/84
Application: PC-DOS, MS-DOS
}

type
  stdstr = string[80];

  RecPack = record
     AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAG:integer;
  end;

var
  regs:RecPack;
  ch:char;

{------------------------}
function StrInt(n:integer):stdstr;
  { return a string with the integer in ASCII }
var s:string[6];
begin
  str(n,s);
  strint := s;
end;

{------------------------}
procedure CallDos(fcn:integer);
  { execute DOS fcn# call }
begin
  with regs do begin
    ax := fcn;
    MsDos(regs);
  end; { with }
 end;

{------------------------}
function timestamp:stdstr;
  { return string of "MON DAY YEAR TIME" }
type mot = array[1..12] of string[3];
const mon:mot = ( 'JAN','FEB','MAR','APR','MAY','JUN',
                  'JUL','AUG','SEP','OCT','NOV','DEC');
var tsret:stdstr; hr:integer;   ampm:string[2]; Min : string[2];
begin
  CallDos($2A00);
  with regs do begin
    tsret :=  mon[Hi(DX)] +' '+ strint(Lo(DX)) +','+ strint(CX)+ '  ';

    CallDos($2C00);
    hr := Hi(cx);
    if hr > 11 then ampm := 'pm'
      else ampm := 'am';
    if hr > 12 then hr := hr - 12;
    min := strint (Lo(cx));
    if length(min)=1 then min := concat('0',min);
    timestamp := tsret + (strint(hr) ) + ':' + min + ampm;
  end;  { with }
end;

{-------------------------------------}
procedure Get_dir;

{ This program should display the disk directory from with any turbo program. }

type
  dir_str = string[12];
  regpack = record
    ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
  end; { recpack }

  var
    name1,name2 : dir_str;
    found       : boolean;
    j           : integer;

{-------------------------------------}
procedure Find_dta ( var dta_seg,dta_ofs : integer);
var
  recpack : regpack;

begin
  with recpack do begin
    ax := $2F shl 8;
    MsDos(recpack);
    dta_seg := es;
    dta_ofs := bx;
  end; { with }
end; { Find_dta }

{-------------------------------------}
function get_filename : dir_str;
var
  i,dta_seg,dta_ofs : integer;
  result            : dir_str;
  c                 : char;

begin
  Find_dta (dta_seg,dta_ofs);
  result := '';
  i := 30;
  c := chr (mem[dta_seg:dta_ofs+i]);
  while c<>chr(0) do begin
    result := concat (result,c);
    i := i + 1;
    c := chr (mem[dta_seg:dta_ofs+i]);
  end; { while }
  get_filename := result;
end; { get_filename }

{-------------------------------------}
procedure dir_first (   source : dir_str;
                    var result : dir_str;
                    var found  : boolean);

var
  recpack : regpack;
  flg     : byte;

begin
  source := concat (source,chr(0));
  with recpack do begin
    ax := $4E shl 8;
    ds := (seg(source));
    dx := (ofs(source) + 1);
  end;

  MsDos(recpack);
  result := '';
  flg := recpack.flags and 1;
  if flg = 0 then begin
    found := true;
    result := get_filename;
  end { if found }
  else found := false;
end; { dir_first }

{-------------------------------------}
procedure dir_next (   source : dir_str;
                   var result : dir_str;
                   var found  : boolean);

var
  recpack : regpack;
  flg     : byte;

begin
  source := concat (source,chr(0));
  with recpack do begin
    ax := $4F shl 8;
    ds := (seg(source));
    dx := (ofs(source)+1);
  end; { with }

  MsDos (recpack);
  result := '';
  flg := recpack.flags and 1;
  if flg=0 then begin
    found := true;
    result := get_filename;
  end
  else found := false;
end;

{----------  MAIN PROGRAM  -----------}
begin
  clrscr; drive := '';
  write ('Dir mask: '); drive[1] := getchar(['A','B','C','D']);
  drive[2] := ':';
  name1 := concat (concat(drive[1],drive[2]),'*.*');
  dir_first (name1,name2,found); writeln; writeln;
  if found then begin
    write (name2:15);
    j := 1;
    repeat
      j := j + 1;
      dir_next (name1,name2,found);
      if found then write (name2:15);
      if j = 4 then begin writeln; j := 0; end;
    until not found;
  end;
  window (1,18,80,25);
end; { procedure get_dir }

{--------------------------------------}
procedure rename (var name : stringtype);
var
  c            : char;
  i,j          : integer;

begin
  clrscr;
  i := length (name);
  j := pos (':',name);
  if j=0 then begin
    if i>7 then delete (name,9,(i-8));
    name := concat (concat(drive[1],drive[2]),name);
  end { if no semicolon }
  else if j<>2 then begin
    delete (name,j,1);
    if i>7 then delete (name,9,(i-8));
    name := concat (drive,name);
  end; { if semicolon wrong }
  i := length (name);
  j := pos('.',name);
  if j=0 then
    name := concat (name,'.dat')
  else if j<>(i-3) then
    delete (name,(j+4),i);
end; { rename }

(********************************** SAVE ******************************)
PROCEDURE SAVE;
var
  v         : integer;
  ok,destroy: boolean;
  i         : integer;

  procedure putfield (r : gradeptr);

  var
    p : gradeptr;
    j : integer;

  begin
    p := r;
    while p<>nil do begin
      writeln (f,p^.title:20,' ',p^.grade);
      p := p^.ptr;
    end; (* while *)
    writeln (f,' [':20,0:4);
  end; (* putfield *)

begin
  get_dir;
  okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
  repeat
    clrscr;
    destroy := true;
    write('Output filename : '); name := '';
    getstring (name,okset);
    if (length (name)=0) then begin
      window (1,1,80,25); exit;
    end;
    rename (name);
    assign(f,name);
{$i-} reset(f); {$i+}
    ok := (ioresult=0);
    if ok then begin
      clrscr; delLine; video (30);
      writeln (beep,name,' already exist on disk'); video (15);
      writeln; write ('Do you wish to destroy file? (Y/N) ');
      if not yes then destroy := false
        else ok := false;
      close (f);
    end; { if file exist }
    close (f);
  until not ok;

  if destroy then begin
    video (30);
    writeln; writeln ('Writing to disk');
    rewrite (f);
    writeln (f,EMPTY);
    i := 0;
    while (i<=MAXSIZE) and (STUDENT[i].name<>'[') do begin
      with STUDENT[i] do begin
        writeln (f,name:20,fptr:10,bptr:10);
        putfield (hmwk);
        putfield (quiz);
        putfield (lab);
        putfield (test);
        writeln (f,final);
      end; (* with *)
      i := i + 1;
    end; (* while *);
    video (15);
    close (f);
    window (1,1,80,25);
  end; (* if *)
end; (* save *)

(******************************* RETRIEVE ********************************)
PROCEDURE RETRIEVE;
var
  i,j,k,l : integer;
  ok      : boolean;
  c       : char;

  procedure getfield (var p : gradeptr);
  var
    s : gradeptr;

  begin
    p := nil;
    new (s);
    readln (f,s^.title,s^.grade);
    while (s^.title[20] <> '[') and not eof(f) do begin
      s^.ptr := p;
      p := s;
      new (s);
      readln (f,s^.title,s^.grade);
    end; (* while *)
  end; (* getfield *)

begin
  okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
  get_dir;
  repeat
    clrscr;
    write('Input filename : '); name := '';
    getstring (name,okset);
    if (length(name)=0) then begin
      window (1,1,80,25); exit;
    end;
    rename (name);
    assign(f,name);
{$i-} reset(f); {$i+}
    ok := (ioresult=0);
    if not ok then begin
      writeln; video (30);
      writeln (beep,'ERROR --- ',name,' not on disk'); video(15);
      ok := false; delay(2000);
    end; { if file exist }
  until ok;
  clrscr; video (30);
  writeln ('  Please wait --- reading input file'); video (15);
  for i := 0 to MAXSIZE do
    HASH [i] := nil;

  readln (f,EMPTY);
  i := 0;
  while not eof(f) do begin
    with STUDENT [i] do begin
      readln (f,name,fptr,bptr);
      getfield (hmwk);
      getfield (quiz);
      getfield (lab);
      getfield (test);
      readln (f,final);
    end; (* with *)
    INSERTHASH (i);
    i := i+1;
  end; (* while *)

  for i := EMPTY to MAXSIZE do with STUDENT[i] do begin
    name := '['; fptr := i+1; bptr := 0; final := 0;
  end; { for i }
  STUDENT[i].fptr := 0;
  close (f);
  window (1,1,80,25);
end; (* RETRIEVE *)

{--------------------------------------}
procedure files;
var
  v         : integer;
  ok,destroy: boolean;
  i         : integer;

begin
  get_dir;
  okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
  repeat
    clrscr;
    destroy := true;
    write('Output filename : '); name := '';
    getstring (name,okset);
    if (length (name)=0) then begin
      window (1,1,80,25); exit;
    end;
    rename (name);
    assign(f,name);
{$i-} reset(f); {$i+}
    ok := (ioresult=0);
    if ok then begin
      clrscr; delLine; video (30);
      writeln (beep,name,' already exist on disk'); video (15);
      writeln; write ('Do you wish to destroy file? (Y/N) ');
      if not yes then destroy := false
        else ok := false;
      close (f);
    end; { if file exist }
    close (f);
  until not ok;

  if destroy then begin
    video (30);
    writeln; writeln ('Writing to disk');
    rewrite (f);
    file_out := true;
    video (15);
    window (1,1,80,25);
  end;
end;

(*********************************** AVERAGE *****************************)

PROCEDURE AVERAGE;
var
  i,j,num        : integer;
  yn             : char;
  ha,qa,la,ta    : real;
  wh,wq,wl,wt,wf : real;
  th,tq,tl,tt,tf : real;
  grades         : array [0 .. 100] of integer;

  function avegrade (i : integer;
                     r : gradeptr):real;
  var
    a : real;
    p : gradeptr;

  begin
    a := 0;
    p := r;
    while p<>nil do
      with STUDENT [i] do begin
        a := a + p^.grade;
        p := p^.ptr;
      end; (* while *)
    if a=0 then
      a := 0.000001;
    avegrade := a;
  end;

begin
  for i := 0 to 100 do
    grades [i] := 0;

  clrscr;
  writeln ('Enter overall weights');
  writeln; wh := 0;
  getreal ('homework: ',wh);
  wq := 0;
  getreal ('    quiz: ',wq);
  wl := 0;
  getreal ('     lab: ',wl);
  wt := 0;
  getreal ('    test: ',wt);
  wf := 0;
  getreal ('   final: ',wf);

  clrscr;
  if not file_out then
    writeln (f,'   NAME              HMWK  QUIZ   LAB  TEST  FINAL  AVERAGE');

  with STUDENT [0] do begin
    th := avegrade (0,hmwk);
    tq := avegrade (0,quiz);
    tl := avegrade (0,lab);
    tt := avegrade (0,test);
    if final=0 then
      tf := 1
    else
      tf := final;
    i  := fptr;
  end; (* with *)

  num := 0;
  repeat
    with STUDENT [i] do begin
      ave := 0;
      ha := avegrade (i,hmwk)*100/th;
      qa := avegrade (i,quiz)*100/tq;
      la := avegrade (i,lab)*100/tl;
      ta := avegrade (i,test)*100/tt;
      ave := (wh*ha + wq*qa + wl*la + wt*ta)/100 + wf*final/tf;
      if (round(ave) in [0 .. 100]) then begin
        num := num + 1;
        grades [round (ave)] := grades [round (ave)] + 1;
      end; (* if *)

      writeln (f,name:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,(final*100/tf):7:1,ave:9:1);
      i := fptr;
      if not file_out then
        if (i mod(15) = 0) then begin
          writeln; write ('To continue press return'); readln;
          y := wherey - 2; gotoxy (1,y);
        end;
    end; (* with *)
  until (i=0);
  if not file_out then begin
  writeln (f); delline;
  write ('Frequency plot? ');
  if yes then begin
    clrscr;
    i := 100;
    while (grades [i] = 0) and (i>0) do
      i := i-1;

    while (num>0) and (i>0) do begin
      write (f,i,' ',chr(124),' ');
      for j := 1 to grades [i] do
        write (f,'*');
      writeln (f);
      num := num - grades [i];
      i := i - 1;
    end; (* while *)
    writeln; write ('To continue press return'); readln;
  end; (* if *)
  end;
end; (* average *)

{------------------- get_print ---------------------}
procedure get_print;
var
  c : char;
  i,code : integer;

begin
  clrscr;
  writeln ('Select printer options');
  writeln;
  writeln ('TYPE STYLE');
  writeln (' 1  - Pica');
  writeln (' 2  - Elite');
  writeln (' 3  - Compressed pica');
  writeln (' 4  - Compressed elite');
  writeln;
  write ('Enter Choice --> '); c := getchar (['1','2','3','4']);
  val(c,i,code);
  writeln; writeln;
  write ('Skip over margin? (Y/N) --> '); c := getchar (['Y','N']);
  if c='Y' then begin p := 60; i := 4 + i; end else p := 66;
  writeln; writeln; write ('Page header --> '); readln (header);

  case i of
    1  : write (lst,chr(18),chr(27),'P');
    2  : write (lst,chr(18),chr(27),'M');
    3  : write (lst,chr(15),chr(27),'P');
    4  : write (lst,chr(15),chr(27),'M');
    5  : write (lst,chr(27),'N',chr(6),chr(18),chr(27),'P');
    6  : write (lst,chr(27),'N',chr(6),chr(18),chr(27),'M');
    7  : write (lst,chr(27),'N',chr(6),chr(15),chr(27),'P');
    8  : write (lst,chr(27),'N',chr(6),chr(15),chr(27),'M');
  end;
  for i := length(header) to headsize do header := concat(header,' ');
end;

(********************************* PRINT *********************************)

PROCEDURE PRINT;
var
  i : char;

begin
  clrscr;
  file_out := false;
  write ('(S) creen or (P) rinter or (F)ile? '); i := getchar (['S','P','F',#13]);
  case i of
    'S' : assign (f,'con:');
    'P' : begin
            assign (f,'lst:');
            get_print;
            writeln (f,' ',header:headsize,'    ',timestamp);
          end;
    'F' : begin
            files;
            if length(name)=0 then exit;
            average;
            exit;
          end;
    #13 : exit;
  end;
  if not file_out then reset (f);
  clrscr;
  writeln ('Do you wish to see:');
  writeln;
  writeln ('  T -- T(itles');
  writeln ('  C -- C(lass grades (one field)');
  writeln ('  I -- I(ndividual''s grade');
  writeln ('  A -- class (A)verages (all fields)');
  writeln ('<cr>-- return to main menu');
  writeln;
  write ('Enter choice: ');
  i := getchar (['A','T','C','I',#13]);

  case i of
    'T' : EXAMINE;
    'C' : PRINTCLASS;
    'I' : PRINTPERSON;
    'A' : AVERAGE;
    #13 : exit;
  end; (* case *)
  write (f,chr(12));
  close (f);
end; (* print *)

(*********************************** NAME *******************************)

PROCEDURE NAMES;

var
  c : char;

begin
  clrscr;
  writeln ('Select option:');
  writeln;
  writeln ('  E -- enter names');
  writeln ('  C -- change name');
  writeln ('  D -- delete name');
  writeln ('<cr>-- return to main menu');
  writeln;
  write ('Enter choice: ');
  c := getchar (['E','C','D',#13]);

  case c of
    'E' : ENTERCLASS;
    'C' : CHANGENAME;
    'D' : DELNAME;
  end; (* case *)
end; (* name *)

procedure get_file (v:stringtype);
var
  i,j,k,l : integer;
  ok      : boolean;
  c       : char;

begin
  okset := ([':','_','.','\'] + ['A'..'Z'] + ['0'..'9']);
  get_dir;
  repeat
    clrscr;
    write(v); name := '';
    getstring (name,okset);
    if (length(name)=0) then begin
      window (1,1,80,25); exit;
    end;
    rename (name);
    assign(f,name);
{$i-} reset(f); {$i+}
    ok := (ioresult=0);
    if not ok then begin
      writeln; video (30);
      writeln (beep,'ERROR --- ',name,' not on disk'); video(15);
      ok := false; delay(2000);
    end; { if file exist }
  until ok;
  close (f);
  window (1,1,80,25);
end;

procedure merge;
var
  i,num,j     : integer;
  f1,f2       : text;
  line1,line2 : string[255];
  eof1,eof2   : boolean;
  grades      : array [0 .. 100] of integer;
  stuname,stuname2      : stringtype;
  qa,la,ha,ta,final,ave : real;
  q,l,h,t,fin,av : real;

begin
  clrscr;
  get_file ('File to merge --> ');
  if length (name)=0 then exit;
  assign (f1,name);
  get_file ('File to merge --> ');
  assign (f2,name);
  files;
  reset(f1); reset(f2); rewrite (f);
  eof1 := false; eof2 := false;
  if eof(f1) then eof1 := true;
  if eof(f2) then eof2 := true;
  if not eof1 then  readln (f1,stuname,ha,qa,la,ta,final,ave);
  if not eof2 then  readln (f2,stuname2,h,q,l,t,fin,av);
  while not eof1 and not eof2 do begin
    if (stuname<=stuname2) then begin
      writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
      readln (f1,stuname,ha,qa,la,ta,final,ave);
      if eof(f1) then eof1 := true;
    end
    else begin
      writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
      readln (f2,stuname2,h,q,l,t,fin,av);
      if eof(f2) then eof2 := true;
    end;
  end; { while }

  if eof2 then begin
    while not eof1 do begin
      if (stuname>stuname2) and eof2 then begin
        eof2 := false;
        writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
        stuname2 := '{';
      end
      else begin
        writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
        readln (f1,stuname,ha,qa,la,ta,final,ave);
        if eof(f1) then eof1 := true;
      end
    end; { while }

    if (stuname2<>'{') then
      if (stuname<=stuname2) then begin
        writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
        writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
      end
      else begin
        writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
        writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
      end
    else writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1)
  end { if eof2 }

  else begin
    while not eof2 do begin
      if (stuname<=stuname2) and eof1 then begin
        eof1 := false;
        writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
        stuname := '{';
      end
      else begin
        writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
        readln (f2,stuname2,h,q,l,t,fin,av);
        if eof(f2) then eof2 := true;
      end
    end;

    if (stuname<>'{') then
      if (stuname<=stuname2) then begin
        writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
        writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
      end
      else begin
        writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
        writeln (f,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
      end
    else writeln (f,stuname2:20,h:5:1,q:6:1,l:6:1,t:6:1,fin:7:1,av:9:1);
  end; { else not eof2 }

  close (f); close (f1); close(f2);
  clrscr;
  write ('Send merged file to printer? ');
  if yes then begin
    for i := 1 to 100 do grades[i] := 0;
    reset (f);
    writeln (lst,'   NAME              HMWK  QUIZ   LAB  TEST  FINAL  AVERAGE');
    writeln (lst,'===========================================================');
    num := 0;
    repeat
      readln (f,stuname,ha,qa,la,ta,final,ave);
      writeln (lst,stuname:20,ha:5:1,qa:6:1,la:6:1,ta:6:1,final:7:1,ave:9:1);
      num := num + 1;
      i := round(ave);
      if (i<=100) and (i>0) then
        grades [i] := grades[i]+1;
      if num mod(60) = 0 then begin
        write(lst,chr(12));
        writeln (lst,'   NAME              HMWK  QUIZ   LAB  TEST  FINAL  AVERAGE');
        writeln (lst,'===========================================================');
      end;
    until eof(f);
    writeln (lst);
    writeln;writeln;
    write ('Frequency plot? ');
    if yes then begin
      write (lst,chr(12));
      i := 100;
      while (grades [i] = 0) and (i>0) do
        i := i-1;

      while (num>0) and (i>0) do begin
        write (lst,i,' ',chr(124),' ');
        for j := 1 to grades [i] do
          write (lst,'*');
        writeln (lst);
        num := num - grades [i];
        i := i - 1;
      end; (* while *)
    end; { if }
  end; (* if *)
  close(f);
end; { merge }

(******************************* MENUDRIVE *******************************)

PROCEDURE MENUDRIVE (c : char);

begin
  case c of
    'N' : NAMES;
    'P' : PRINT;
    'G' : WHO;
    'S' : SAVE;
    'R' : RETRIEVE;
    'M' : merge;
  end; (* case *)
end; (* menudrive *)

(********************************** MENU *********************************)

PROCEDURE MENU;
var
  i : integer;
  c : char;

begin
  repeat
  clrscr;
  writeln;
  writeln ('GRADE MANAGEMENT SYSTEM   *** Version 3.0 ***');
  writeln;
  writeln ('Memory available: ',MEMAVAIL,' PARAGRAPHS');
  writeln;
  writeln;
  writeln ('Choose option from below: ');
  writeln;
  writeln ('  N -- names');
  writeln ('  P -- print');
  writeln ('  G -- grades');
  writeln ('  S -- save file to disk');
  writeln ('  R -- retrieve file from disk');
  writeln ('  M -- merge files');
  writeln ('  L -- leave program');
  writeln;
  write ('Enter choice: ');
  c := getchar (['N','P','R','S','G','L','M',#13]);

  MENUDRIVE (c);
  until c in (['L']);
end; (* menu *)

begin
  textbackground (4);
  video (15);
  INITIALIZE;
  beep := chr(7);
  nameset := ['A'..'Z',' ',',','.'];
  MENU;
end.