program PASSWORD_TYPE1;

Uses Crt, Design;

var password : string;
    passwordcheck : boolean;

procedure Secret_readln(var s : string);
var c : char;
   li : integer;
begin
  repeat
    c := readkey;
    if c <> #8 then begin;
      s := s + c;
      gotoxy(24,12);
      for li := 1 to length(s) do write('*');
    end else begin;
      s := copy(s,1,length(s)-1);
      gotoxy(24,12);
      for li := 1 to length(s) do write('*');
      write(' ');
      gotoxy(wherex-1,wherey);
    end;
  until c = #13;
end;

procedure Change_password;
begin
  save_screen;
  window(10,8,60,7,' Change password ',black,7);
  writexy(13,10,'Please enter your new password');
  writexy(13,12,'Password: ');
  password := '';
  secret_readln(password);
  restore_screen;
  textcolor(7);
  textbackground(black);
end;

Function Gen_checksum(pasw : string) : word;
var sum : word;
    li : integer;
begin
  sum := 0;
  for li := 1 to ord(pasw[0]) do begin
    sum := sum + ord(pasw[li]);
  end;
  Gen_checksum := sum;
end;

function Encrypt(pasw : string;add : char) : string;
var li : integer;
begin
  for li := 1 to 255 do begin
    pasw[li] := char(255 xor (ord(pasw[li]) + ord(add)));
  end;
  encrypt := pasw;
end;

procedure Save_password;
var pwf : file;
    key : char;
    check : word;
begin
  check := gen_checksum(password);
  password := encrypt(password,key);
  assign(pwf,'password.dat');
  rewrite(pwf,1);
  blockwrite(pwf,key,1);
  blockwrite(pwf,password,256);
  blockwrite(pwf,check,2);
  close(pwf);
end;

procedure QueryPassword;
begin
  save_screen;
  window(10,8,60,7,'Query Password',black,7);
  writexy(13,10,'Please enter your password');
  writexy(13,12,'Password: ');
  password := '';
  secret_readln(password);
  restore_screen;
  textcolor(7);
  textbackground(black);
end;

function Decrypt(pasw : string;add : char) : string;
var li : integer;
begin
  for li := 1 to 255 do begin
    pasw[li] := char((255 xor ord(pasw[li])) - ord(add));
  end;
  decrypt := pasw;
end;

function Checksum_Ok(pasw : string; Key: char; sum : word) : boolean;
var tsum : word;
    li : integer;
    h : char;
begin
  tsum := 0;
  for li := 1 to ord(pasw[0]) do begin;
    tsum := tsum + ord(pasw[li]);
  end;
  if sum = tsum then
    Checksum_Ok := true
  else
    Checksum_Ok := false;
end;

procedure CheckPassword;
var pwf : file;
    key : char;
    check : word;
    should_pass : string;
begin
  assign(pwf,'password.dat');
  reset(pwf,1);
  blockread(pwf,key,1);
  blockread(pwf,should_pass,256);
  blockread(pwf,check,2);
  close(pwf);
  should_pass := decrypt(should_pass,key);
  if Checksum_Ok(should_pass,key,check) and (should_pass = password) then
    PasswordCheck := true
  else
    PasswordCheck := false;
end;

procedure RespondPassword;
begin
  save_screen;
  window(10,8,40,7,'',black,7);
  If PasswordCheck then begin
    writexy(13,11,'Password correct - Access granted');
  end else begin
    writexy(13,11,'Password WRONG ! - No access !');
  end;
  repeat until keypressed; readkey;
  restore_screen;
  textcolor(7);
  textbackground(black);
end;

procedure Menu;
var choice : byte;
begin
  repeat
    clrscr;
    writexy(10,1,'Example program for password type 1  (c) ''95 by ABACUS ');
    writexy(20,4,'M E N U');
    writexy(20,5,'~~~~~~~');
    writexy(15,6,'1)  Change Password');
    writexy(15,8,'2)  Query Password');
    writexy(15,10,'3)  End');
    writexy(15,13,'Your Choice: ');
    readln(choice);
    if choice = 1 then begin
      Change_password;
      Save_password;
    end;
    if choice = 2 then begin
      QueryPassword;
      CheckPassword;
      RespondPassword;
    end;
  until choice = 3;
end;

begin
  Menu;
end.