program grades(input,output);  
(* calculate grades   
      paul juell 10/16/82  
      edited 10/25/82 unix 
      compile with pc
 *)  
const  
  trace       =1;  
  fieldwidth  =3; (*columns per input entry *) 
  maxline     =80; 
  maxstudents = 250; 
  maxitems    =22; 
  maxtypes    =5;  
  maxpoints   =0; (*subscript of max points in table *)  
  tallyat     =maxitems;  
  lowbreak    = 1;  
  highbreak   =16;  
  ghostbreak  =highbreak;  
  namesize    = 20; 
  (* 
  namesize    = namesize; 
  *) 
type  
  alfa =packed array[1..10] of char; 
  typeline = 
   record 
     use :integer; 
     len :integer; 
     c   : array[1..maxline] of char; 
   end; 
  typename    =  array[1..namesize] of char; 
  typelgrade  =  array[1..2] of char; 
  typestudent =  
   record  
    (* 
    name  : packed array[20] of char; 
    lettergrade: packed array[2] of char;  
    *) 
    name  : typename; 
    lettergrade: typelgrade; 
    item       : array[1..maxitems] of integer;  
   end;  
  typetype    =  
   record  
    name  : typename; 
    num   : 0..maxitems;  
    first : 0..maxitems;  
    last  : 0..maxitems;  
   end;  
  rangetable = maxpoints..maxstudents;  
  rangetypes = 0..maxtypes;  
  rangeitems = 0..maxitems;  
  typetable= array[rangetable] of typestudent;  
  typepvec = array[rangetable] of rangetable;  
                (* pointer vector for sorting and  
                   listing table  
                 *)  
  typevectypes= array[1..maxtypes] of typetype;  
  rangebreak = lowbreak..highbreak;  
  typebreak  = array[rangebreak] of integer;  
  typegbreak = array[rangebreak] of typelgrade; 
var  
  perat   :integer;fout:text; 
  line   : typeline; 
  class  : typetable;  
  pvec   : typepvec;  
  types  : typevectypes;  
  numstudent: rangetable; 
  numtypes  : rangetypes; 
  break     :typebreak;  
  gradebreak:typegbreak;  
  head :typeline; 
  dateis, timeis : alfa; 
 
procedure getline(var line:typeline); 
begin 
  line.len := 0;  (* length of line read *) 
  line.use := 1;  (* next char to use in line *) 
  if not eof then 
   begin 
    while not eoln do 
     begin 
      line.len := line.len + 1; 
      read( line.c[ line.len]); 
     end; 
    readln; 
   end; 
end;(*getline*) 
 
procedure putline(var line:typeline); 
var 
  i :integer; 
begin 
  for i:= 1 to line.len do 
    write( line.c[ i ] ); 
  writeln; 
end;(*putline*) 
 
procedure getfield(fieldwidth:integer; var line:typeline; var val:integer); 
var 
  t : integer; 
  i:  integer; 
  break:boolean; 
begin 
  break := false; 
  t:= 0; 
  for i:=1 to fieldwidth do 
   begin 
    if line.use <= line.len then 
     begin 
      if line.c[line.use] in ['0'..'9'] then 
        t := t * 10 +(ord(line.c[line.use]) -ord('0')) 
      else 
        if t > 0 then 
          break := true 
      ; 
     end; 
    line.use := line.use + 1; 
   end; 
  if break then 
    writeln('**** error in input starting in col ',line.use); 
  if break and (trace > 0) then 
    putline(line); 
  val := t; 
end;(*getfield*) 
 
 procedure getname(var name:typename); 
 var 
   i,j:integer; 
   c:char; 
 begin 
  i:=0; 
  while not eoln and (i<20) do 
   begin 
    i:=i+1; 
    read(c); 
    name[i]:=c; 
   end; 
  readln; 
  for j:=i + 1 to namesize do 
   name[j]:=' '; 
 end;(*getname*) 
  
 procedure putname(var name:typename); 
 var 
   i:integer; 
 begin 
   for i:=1 to namesize do write(name[i]); 
 end;(*putname*) 
 
procedure loadtypes(var types: typevectypes;  
                    var numtypes:rangetypes);  
var  
  i :integer;  
begin  
  readln( numtypes);  
  for i:= 1 to numtypes do  
    with types[i] do  
     begin  
      getname(name); 
      read(num);  
      readln;  
     end;  
end;(*loadtypes*)  
  
procedure setuptypes(var types:typevectypes;  
                         numtypes:rangetypes);  
                (* setuptypes and sub control item subcripting*)  
var  
  i,j,lastused:integer;  
begin  
  lastused := 0;  
  for i:=1 to numtypes do  
   begin  
    with types[i] do  
     begin  
      first := lastused + 1;  
      last  := first + num -1;  
      lastused := last;  
     end;  
   end;  
  if lastused >= maxitems then  
    writeln('***too many items requested ***');  
end;(*setuptypes*)  
  
function sub( subtype:rangetypes;subitem:rangeitems)  
        : rangeitems;  
var  
  temp:integer;  
begin  
  if trace >3 then writeln('enter sub ',subtype:3,subitem:3);  
  if subtype > numtypes then  
   begin  
    writeln('***type not in range***',subtype);  
   end;  
  if subitem > types[subtype].num then  
   begin  
    writeln('***item not in range***',subitem);  
   end;  
  temp:= types[subtype].first + subitem -1;  
  sub := temp;  
end;(*sub*)  
  
procedure getstudent( var s:typestudent; 
                      var endstudents: boolean);  
var  
  i,j: integer;  
  tempstr: typename; 
 
begin  
  if trace > 2 then  
    writeln('debug enter getstudent');  
  if eof then  
   begin  
    endstudents := true;  
   end  
  else  
   begin  
    getname(tempstr); 
    if tempstr[1] = '$' then  
     begin  
      endstudents := true;  
     end  
    else  
     begin  
      if trace > 0 then 
        begin putname( tempstr); writeln; end;
      endstudents := false;  
      with s do  
       begin  
        name := tempstr;  
        for i := 1 to numtypes do  
         begin  
          getline(line); 
          for j:=1 to types[i].num do  
            getfield(fieldwidth,line,item[sub(i,j)]); 
         end;  
       end  
     end;  
   end;  
  if trace > 2 then  
    writeln('debug leave getstudent');  
end;(*getstudent*)  
  
procedure loadstudents(var class:typetable;  
                       var numstudent:rangetable; 
                       var types:typevectypes;  
                           numtypes:rangetypes);  
var  
  endstudents : boolean;  
  count:integer;  
begin  
  count := -1;          (* maxpoints goes into class[0] *)  
    
  endstudents :=false;  
  repeat  
   begin  
    count := count + 1;  
    if count = maxstudents then  
      writeln('*** too many students, only processing ',maxstudents)   
    else  
    getstudent(class[count],endstudents);  
   end;  
  until (count >= maxstudents) or endstudents;  
  numstudent := count - 1; 
  writeln('debug leave loadstudents ',numstudent); 
end;(*loadstudents*)  
  
procedure sortnames   (var class:typetable;  
                           numstudent:rangetable; 
                       var pvec:typepvec  
                       );  
var  
  i,j:integer;  
  temp:integer;  
 
 function lt(var n1,n2:typename):boolean; 
 var 
  i:integer; 
 begin 
  i:=1; 
  while (i<namesize) and (n1[i]=n2[i]) do 
    i:=i+1; 
  lt := n1[i] < n2[i]; 
 end;(*lt*) 
 
begin  
  writeln('debug enter sortnames');  
  for i:= maxpoints to numstudent do 
    pvec[i] := i;  
  for i := 2 to numstudent do 
    for j := i downto 2 do  
      if lt( class[pvec[j]].name , class[pvec[j-1]].name) then 
       begin  
        temp:=pvec[j];  
        pvec[j]:=pvec[j-1];  
        pvec[j-1]:=temp;  
       end;  
  writeln('degub leave sortnames');  
end;(*sortnames*)  
  
procedure sortitems   (var class:typetable;  
                           numitem:rangeitems; 
                           numstudent:rangetable; 
                       var pvec:typepvec  
                       );  
var  
  i,j:integer;  
  temp:integer;  
  done:boolean; 
begin  
  writeln('sorting ',numstudent,' students'); 
  for i:= maxpoints to numstudent do 
    pvec[i] := i;  
  for i := 2 to numstudent do 
   begin 
    j:= i; 
    done:= false; 
    while (j >= 2) and not done do 
     begin 
      if class[pvec[j]].item[numitem] > class[pvec[j-1]].item[numitem] then  
       begin  
        temp:=pvec[j];  
        pvec[j]:=pvec[j-1];  
        pvec[j-1]:=temp;  
       end 
      else 
       done := true 
      ; 
      j := j - 1; 
     end; 
   end; 
end;(*sortitems*) 
  
procedure dotally(var class:typetable;  
                      numstudent:rangetable; 
                      types:typevectypes;  
                      numtypes:rangetypes  
                  );  
var  
  stud,t,i : integer;  
  sum: integer;  
begin  
  writeln('debug enter dotally');  
  for stud := maxpoints to numstudent do 
   with class[stud] do  
   begin  
    sum := 0;  
    for t := 1 to numtypes do  
      for i := 1 to types[t].num do  
        sum := sum +  item[sub(t,i)];  
    item[tallyat] := sum;  
   end;  
end;(*dotally*)  
  
procedure calcgrades(var class:typetable;  
                         numstudent:rangetable; 
                         types:typevectypes;  
                         numtypes:rangetypes;  
                         break:typebreak  
                     );  
var  
  i,j, k : integer; 
begin  
  for i := maxpoints to numstudent do 
    with class[i] do  
     begin  
      item[perat] := trunc( item[tallyat] / class[maxpoints].item[tallyat]  
                           *100.0 + 0.5);  
      j:= lowbreak;  
      while (j <highbreak) and (item[perat] < break[j]) do  
        j := j + 1;  
      for k:=1 to 2 do 
        lettergrade[k] := gradebreak[j][k]; 
     end;  
end;(*calcgrades*)  
  
procedure initbreak;  
var  
  i,j,k : integer; 
  c:char;  
begin  
  for i:= 0 to highbreak - lowbreak do  
   begin  
    j := i + lowbreak;  
    gradebreak[j][1] := ' '; 
    gradebreak[j][2]:=' '; 
    gradebreak[j][1] := chr(ord('a') + i div 3); 
    case i mod 3 of  
    0: c:='+';  
    1: c:=' ';  
    2: c:='-';  
    end;(*case*)  
    gradebreak[j][2] := c; 
   end;  
  gradebreak[ghostbreak][1] :='f'; 
  gradebreak[ghostbreak][2] :=' '; 
  gradebreak[highbreak][1]  :='f'; 
  gradebreak[highbreak][2]  :=' '; 
  for i := 0 to highbreak - lowbreak do  
   begin  
    j := i + lowbreak;  
    case i mod 3 of  
    0: break[j] := 100 -3 - i div 3 * 10;  
    1: break[j] := 100 -6 - i div 3 * 10;  
    2: break[j] := 100 -10- i div 3 * 10;  
    end;  
   end;  
  break[ghostbreak] := 30;  
end;(*initbreak*)  
  
procedure loadbreak; 
(* load break line, if blank line use default*) 
var 
  j : integer; 
  temp: typebreak; 
begin 
  getline(line); 
  for j:=  lowbreak to highbreak do 
    getfield(fieldwidth,line,temp[j]); 
  if temp[lowbreak] > 0 then 
    for j:=  lowbreak to highbreak do 
      break[j] := temp[j]; 
end;(*loadbreak*) 
 
procedure showbreak; 
var 
   i : integer; 
   j : integer; 
begin 
  for i:= lowbreak to highbreak do 
   begin 
    if i = (lowbreak + highbreak) div 2 then 
      writeln; 
    write(gradebreak[i][1],gradebreak[i][2]); 
    write(break[i]:4,' '); 
   end; 
  writeln; 
end;(*showbreak*) 
  
  
  
procedure printgrades(    showname:integer;
		      var class:typetable;  
                          numstudent:rangetable; 
                      var types:typevectypes;  
                          numtypes: rangetypes;  
                      var pvec :typepvec  
                      );  
var   
  stud,t,i : integer;  
begin  
  putline( head ); 
(*
  writeln( dateis,'   ',timeis); 
*)
  for stud := maxpoints to numstudent do 
   with class[pvec[stud]] do  
   begin  
    if showname>0 then putname(name); 
    write(lettergrade[1]:1,lettergrade[2]:2); 
    write(item[perat]:4);  
    write(item[tallyat]:4);  
    for t :=1 to numtypes do  
      for i:= 1 to types[t].num do  
        write(item[sub(t,i)]:3);  
    writeln;  
   end;  
end;(*printgrades*)  
  
procedure dogrades;  
begin  
  getline( head ); 
  putline( head ); 
  loadbreak; 
  loadtypes(types,numtypes);  
    setuptypes(types,numtypes);  
  loadstudents(class,numstudent,types,numtypes); 
  dotally(class,numstudent,types,numtypes); 
  calcgrades(class,numstudent,types,numtypes,break); 
  sortnames(class,numstudent,pvec); 
  showbreak; 
  printgrades(1,class,numstudent,types,numtypes,pvec); 
  sortitems(class,tallyat,numstudent,pvec); 
  printgrades(1,class,numstudent,types,numtypes,pvec); 
  printgrades(0,class,numstudent,types,numtypes,pvec); 
end;(*dogreades*)  
 
(*
procedure doopen; 
var 
  s:string; 
begin 
  writeln('enter  input file'); 
  readln(s); 
  if length(s) = 0 then 
    s := 'console:' 
  else 
    s := concat(s, '.text') 
  ; 
  reset(s); 
  writeln('enter output file'); 
  readln(s); 
  if length(s) = 0 then 
    s := 'console:' 
  else 
    s := concat(s, '.text') 
  ; 
  rewrite(s); 
end;(*doopen*) 
 
  
begin  
  perat := tallyat-1; 
(*
  doopen; 
  reset;
  rewrite;
*)
  (* 
  time(timeis); 
  date(dateis); 
  *) 
  initbreak;  
  dogrades;  
(*
  close(lock); 
  close; 
*)
end.