segment externals;

   {External routines for Database package}

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

TYPE
   {$I b:lptype};
 
VAR
   chainfile: prog;
   attr_clear, last_address: integer;
   Origx, Origy: Byte;

PROCEDURE ClrScr; EXTERNAL;
PROCEDURE ClrEol; EXTERNAL;
PROCEDURE GoToXY(Col, Row: byte); EXTERNAL;
FUNCTION ConSilent: char; EXTERNAL;
FUNCTION CStat: boolean; EXTERNAL;

PROCEDURE Ready_Keyboard;
   BEGIN
      {null for the PC}
      Origx := 0; Origy := 0;
      scr_inv := ''; scr_nor := '';
      disc := 'b:';
   END;

PROCEDURE cursor(y,x: integer);
   BEGIN
{     write(chr(1bh), 'Y', chr(y+20h), chr(x+20h))};
      GoToXY(x+Origx+1, y+Origy+1);
   END;

PROCEDURE clearscreen;
   BEGIN
{      write(chr(1bH)); write('E'); cursor(0, 1);  }
       ClrScr;
   END;

PROCEDURE Clear_from_Line(n: integer);
   VAR i: byte;
   BEGIN
{     cursor(n, 0); write(chr(1bh), 'J');}
      For i := n+Origy to 24 do begin; cursor(i, 0); ClrEol end;
   END;

PROCEDURE Clearline(n: integer);
   BEGIN
      cursor(n,0); { write(chr(1bH),'K')};
      ClrEol;
   END;

PROCEDURE Clear_to_end;
   BEGIN
 {     write(chr(1bh), chr(4bh)); }
       ClrEol;
   END;

PROCEDURE set_viewport(n: integer);
   BEGIN
    {  write(chr(1bH),'X',chr(n+33),chr(32),chr(28+32),chr(90-1+32));}
       {set 1,0,29,90 - protects top row}
       origy := 1;
   END;

PROCEDURE reset_viewport;
   BEGIN
    {  write(chr(1bH),'X  ',chr(30+32),chr(90+32)); }
    Origy := 0;
   END;

FUNCTION get: char;
   VAR Key: char;
       x: real;
   BEGIN
      key := consilent;
      if ord(key) = 3 then x := sqrt(-1);  {force an error}
      if ord(key) = 27 then write('EXIT') else write(key);
      get := key; 
   END;

Function Test_Input: boolean;
   BEGIN
      Test_Input := CStat;
   END;

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<>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;
   END;

PROCEDURE Request_Register;
   var i: byte;
       ofn, rfn, nfn, ffn: string[14];
   BEGIN
      clearscreen;
      REPEAT
      cursor(22, 0); i := 1;
      write('Register Name?'); readln(reg);
      if pos(':', reg) = 2 then begin
         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');
      if not fstat(ofn) then begin
         cursor(24,0);
         writeln('Database file missing, please check name or change disc!');
         cursor(22, 12); write('      '); i := 0;
      end;
      UNTIL i<>0;
      reset_viewport;
      clearscreen;
      writeln('Register: ',reg);
      set_viewport(1);

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

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

PROCEDURE Close_Register;
   BEGIN
      close(dbfile, true); close(rdfile, true); 
      close(nafile, true); close(fafile, true);
   END;

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


PROCEDURE set_party;
  VAR i: integer;
  BEGIN
    party[0] := '???'; sparty[0] := '?';
    party[1] := 'Lab'; sparty[1] := 'L';
    party[2] := 'Con'; sparty[2] := 'C';
    party[3] := 'All'; sparty[3] := 'A';
    party[4] := 'SNP'; sparty[4] := 'S';
    party[5] := 'Gre'; sparty[5] := 'G';
    party[6] := 'Agt'; sparty[6] := 'A';
    party[7] := 'Pos'; sparty[7] := 'P';
    party[8] := 'D/K'; sparty[8] := 'D';

    max_attr := 15;
    attrn[1] := 'Moved/Dead     '; attrn[2] := 'Postal Vote    ';
    attrn[3] := 'New Voter      '; attrn[4] := 'Window Poster  ';
    attrn[5] := 'Member         '; attrn[6] := 'Car Wanted     ';
    attrn[7] := 'Council Tenant '; attrn[8] := 'Student        ';
    attrn[9] := 'Pensioner      '; attrn[10]:= 'In Master File ';
    attrn[11]:= 'Voted last Time'; attrn[12]:= 'Voted this time';
    attrn[13]:= 'Promise Card   '; attrn[14]:= 'Parent         ';
    attrn[15]:= 'Green/FOE      ';

    stylea[0] := '     '; stylea[1] := 'Mr.  '; stylea[2] := 'Mr.  ';
    stylea[3] := 'Miss '; stylea[4] := 'Jnr. '; stylea[5] := 'Ms.  ';
    stylea[6] := '     '; stylea[7] := '     ';
 END;

PROCEDURE get_address(n: integer);
   BEGIN
      if last_address <> n then seek(rdfile, n);
      last_address := n;
   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  ('                                                         ');

     if dbfile^.attr = [] then begin
        cursor(q,10); write('[None]');
        attr_clear := 0;
     end else begin
        qo := q;
        j := 1; cursor(q, 10);
        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,10); j := 1;
              end;
           end;
        end;
        attr_clear := q-qo+1;    {how much screen to clear next time round}
     end;
   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 display_entry(n: s_integer);
   VAR
     pos: integer;
   BEGIN
     get_names;
     pos := 3;
     cursor(pos, 0);   writeln('Register no.  ', n:8);
                       write  ('Surname:          ', surname); clear_to_end;
     cursor(pos+2,0);  write  ('First name&init   ', firstname, dbfile^.init);
                                                       clear_to_end;
     cursor(pos+3,0);  write  ('House no.         ',housename); clear_to_end;
     cursor(pos+4,0);  writeln('Street:           ');
     cursor(pos+6,0);  writeln('Voting intention: ',party[cvote]);
                       writeln('Previous:         ',party[pvote]);
     cursor(pos+9,0);  writeln('Further Information:');
     print_attributes(pos+10);

     cursor(pos+1,40); writeln('Style: ',stylea[dbfile^.style]);
     get_address(dbfile^.street);
     cursor(pos+4, 18); writeln(rdfile^.street); clear_to_end;
  END;

PROCEDURE back_to_menu;
   BEGIN

      reset_viewport; clearscreen; Close_register;

      assign(chainfile, 'lpmenu.com'); reset(chainfile);
      chain('lpmenu.exe');
   END;

BEGIN
END.