segment externals;

   {External routines for Database package}

   {Brian Gilmore August 1987}
                 {October - modified for new database format}

TYPE
   {$I lptype}
 
VAR
   control: text;
   chainfile: prog;
   attr_clear, last_address: byte;

   {$I HARDWARE}

FUNCTION readint: integer;
   VAR i, j, n, q: integer;
   BEGIN
      n := 0; final := -1; q := 0;
      REPEAT
         i := ord(get); j := i-ord('0');
         if (j>=0) and (j<=9) then begin
            n := n*10+j; q := 1;
         end else final := i;
      UNTIL final > 0;
      if q = 0 then n := -1;
      readint := n;
   END;

FUNCTION getchar: integer;
   VAR i: integer;
   BEGIN
      i := ord(get);
      getchar := i;
   END;   

FUNCTION getint(x, y:integer): integer;
   VAR i,j,n,fl: integer;
   BEGIN
      fl := 0;
      REPEAT
         write('           '); cursor(x, y);
         n := readint;
         if ((final<30) and (final>32) and
              (final<>27) and (final<>13)) or (n>65000) then begin
            cursor(x+1,0); write('Not a number, please retype');
            cursor(x, y); write('                '); cursor(x, y);
         end else fl := 1;
      UNTIL fl <> 0;
      getint := n;
      clearline(x+1);
   END;

FUNCTION get_option(from, tx, flag : byte): integer;
   VAR i, j,  inp: integer;
       c, f1, f2 : char;              {flag = 0 => numeric        }
       pos, x, high, n, oh : byte;    {     = 1 => no strings     }
   BEGIN
      inp := -1;
      pos := 3; high := from; 
      if flag = 0 then begin
         clear_from_line(0); write(scr_inv, title);
         for x := from to tx do begin
            cursor(pos+x*2, 10); write(x: 2, '  -  ', mess[x].s, scr_nor);
         end;               
      end;
      repeat
         inp := -1; oh := high;
         if from < 5 then begin
            f1 := chr(from+48); f2 := chr(tx+48)
         end else begin
            f1 := chr(from); f2 := chr(tx)
         end;
         cursor(23,0); write('Option (',f1,'-',f2,')? ', 
                             scr_inv, ' ', scr_nor);
         cursor(23, 14); c := get; n := ord(c); 
         if c < '0' then begin
            final := n;
            if n = 30 then begin {cursor down}
               if high < tx then high := high+1
            end else begin
               if n = 31 then  {cursor up}
                  if high > from then high := high-1;
            end;
            if (n=13) or (n=27) then inp := high; 
                                                 {return, terminates with current highl}
                                                 {exit/esc - passes back -1}
            if flag = 0 then begin
               cursor(pos+oh*2, 10); write(oh : 2, '  -  ', mess[oh].s);
               cursor(pos+high*2, 10); write(scr_inv, high:2, 
                                           '  -  ', mess[high].s, scr_nor);
            end;
         end else begin
            inp := n; if from<5 then inp:=inp-ord('0');
            if (inp<from) or (inp>tx) then begin
               cursor(23, 20); write('Invalid, please re-enter');
               inp := -1
            end;
         end;
      until inp >= from;
      clearline(23); title := '';
      if from > 5 then inp := inp-ord('a')+1;
      if (flag<>0) and (n=13) then inp := -1;      {see above}
      if n=27 then inp := -1;
      get_option := inp; 
   END;

PROCEDURE Request_Register;
   var i: byte;
       ofn, nfn, rfn, ffn, pfn: string[14];
       s : string[35];
   BEGIN
      s := instring;
      REPEAT
      i := 1;
      if s = '' then begin     {no input file specification}
         clearline(max_row-2);
         write('Register Name?'); readln(reg);
      end else begin
         reg := s;  s := '';
         cursor(21,0); writeln('[', reg, ']');
      end;
      if pos(':', reg) = 2 then begin        {force a disc drive specification}
         disc := copy(reg, 1, 2);
         if length(reg)>2 then reg := copy(reg, 3, length(reg)-2);
      end;

      rfn := concat(disc,reg,'.STR');
      ofn := concat(disc,reg,'.DAT');
      nfn := concat(disc,reg,'.NAM');
      ffn := concat(disc,reg,'.FNA');
      pfn := concat(disc,reg,'.POC');
      if not fstat(ofn) then begin
         cursor(max_row-2,30);
         write('Database file missing, Check name or Change disc!');
         cursor(max_row-2, 15); write('      '); i := 0;
      end;
      UNTIL i<>0;
      reset_viewport; cursor(0, 0);
      writeln(scr_inv, 'Register: ',reg, scr_nor);
      clearline(max_row-2);
      set_viewport(1);

      assign(dbfile, ofn); update(dbfile);
      assign(rdfile, rfn); update(rdfile); 
      assign(nafile, nfn); update(nafile);
      assign(fafile, ffn); update(fafile);
      assign(pofile, pfn); update(pofile);

      seek(dbfile, 0); max_val := dbfile^.namind;
   END;

PROCEDURE show_attributes;
   VAR i, j: integer;
   BEGIN
      for i := 1 to max_attr do begin
         cursor(7+i, 60); write(chr(i-1+ord('a')),'  ',attrn[i]);
      end;
   END;

PROCEDURE get_address(n: integer);
   BEGIN
      if last_address <> n then seek(rdfile, n);
      last_address := n;
   END;

PROCEDURE Get_Postcode(n: s_integer);
   VAR i: byte;
       pc: string [9];
   BEGIN
      i := rdfile^.postind;                  {index to 1st postcode for that street}
      REPEAT
         seek(pofile, i);
         postcode := pofile^.postcode;
         i := i+1;
      UNTIL (pofile^.r_no > n) or eof(pofile);        {have now gone past the correct one}
   END;

PROCEDURE print_attributes(q: integer);
   VAR i, j, k, qo: s_integer;
   BEGIN
     cursor(q, 0);
     if attr_clear <> 0 then 
        writeln('                                                        ');
     if attr_clear > 1 then
        writeln('                                                        ');
     if attr_clear > 2 then 
        write  ('                                                        ');

     write(scr_inv);
     if dbfile^.attr = [] then begin
        cursor(q,5); write('[None]');
        attr_clear := 0;
     end else begin
        qo := q;
        j := 1; cursor(q, 5);
        for i := 1 to max_attr do begin
           k := 0;
           if [i] * dbfile^.attr <> [] then begin
              write(attrn[i],'  ');
              j := j+1;
              if j = 4 then begin
                 q := q+1; cursor(q,5); j := 1;
              end;
           end;
        end;
        attr_clear := q-qo+1;    {how much screen to clear next time round}
     end;
     write(scr_nor);
   END;

PROCEDURE getstr(VAR s:sts; VAR x: s_integer);
   VAR i, j: byte;
   BEGIN
      seek(nafile, x); x := x+1;
      s := '';
      j := ord(nafile^);
      if j > 0 then begin
         for i := 1 to j do begin
            seek(nafile, x); x := x+1;
            s := concat(s, nafile^);
         end;
      end;
   END;

PROCEDURE getstf(VAR s:sts; VAR x: s_integer);
   VAR i, j: byte;
   BEGIN
      seek(fafile, x); x := x+1;
      s := '';
      j := ord(fafile^);
      if j > 0 then begin
         for i := 1 to j do begin
            seek(fafile, x); x := x+1;
            s := concat(s, fafile^);
         end;
      end;
   END;

PROCEDURE bday(VAR x: s_integer);
   VAR i, j: s_integer;
   BEGIN
      seek(fafile, x); x := x+1;
      i := ord(fafile^); birthday[1] := i;
      if i <> 0 then begin
         seek(fafile, x); x := x+1;
         birthday[2] := ord(fafile^);
         seek(fafile, x); x := x+1;
         birthday[3] := ord(fafile^);
      end;
   END;


PROCEDURE get_names;
   VAR x, y: s_integer;
       vote: byte;
   BEGIN
           {get surname & firstname from the NAME file}

      x := dbfile^.namind;    {pointer for surname in name file}
      y := dbfile^.fnameind;  {pointer for firstname in firstname file}
      getstr(surname, x);
      getstf(firstname, y);
      getstr(housename, x);
      bday(y);
 
      vote := dbfile^.xvote;
      pvote := vote DIV 16;
      cvote := vote MOD 16;
   END;

PROCEDURE Disp_Form;
   VAR
     pos: integer;
   BEGIN
     pos := 3;
     cursor(pos, 0);   writeln('Register no.  '); writeln;
                       write  ('Surname');clear_to_end;
     cursor(pos+4,0);  write  ('First name&init');

                                                       clear_to_end;
     cursor(pos+6,0);  write  ('House no.'); clear_to_end;
     cursor(pos+8,0);  writeln('Street:');
     cursor(pos+10,0);  writeln('Voting intention: ');
                        writeln('Previous:');

     cursor(pos+13,0);  writeln('Further Information:');

     cursor(pos+2,40); writeln('Style: '); 
  END;

PROCEDURE mvx(n:byte);
   BEGIN
      cursor(n, 18); write(' ');
   END;

PROCEDURE disp_Voter(n: s_integer);
   VAR
     pos: integer;
   BEGIN
     get_names;
     pos := 3;
     write(scr_inv);
     mvx(pos);   write(n:5);
     mvx(Pos+2); write(surname, '        '); 
     mvx(pos+4);  write(firstname, dbfile^.init, '       ');
     mvx(pos+6);  write(housename, '    ');

     mvx(pos+10); write(party[cvote]);
     mvx(pos+11); write(party[pvote]);

     print_attributes(pos+14);

     cursor(pos+2,48); write(scr_inv, stylea[dbfile^.style]);
     get_address(dbfile^.street);
     mvx(pos+8); writeln(rdfile^.street);
     write(scr_nor);
  END;

PROCEDURE Display_Entry(n: s_integer);
   BEGIN
      Disp_form;
      Disp_Voter(n);
   END;

BEGIN
END.