Program Generate_PWD;
{$M 65520, 0, 0}
{Вообще, если генерировать пароли по строкам, отличающимся
только в нескольких местах, надо эти места найти, и только их изменять}
Uses CRT;
const
  tmpFileName = 'gpwd.tmp';
var
  Count, Cnt   : Longint;
  i, j         : Word;
  l, Pos, Pos1 : Word;
  SRes, p, ap  : String;
  Sap, pp, app : String;
  FNm          : String;
  Sf           : Boolean;
  Regis        : array[0..15] of Word;
  M            : Word;
  Mask         : array[1..256] of Boolean;
  f, fRes      : Text;
  Noch         : Boolean;
Procedure Decline(N : Word);
begin
  dec(Regis[N]);
  if N<15 then
   begin
    if Regis[N]=$FFFF then
      if N<>15 then Decline(N+1)
        else Sf := True;
   end;
end;
Function CheckZero : Boolean;
var
  i : Byte;
  z : Boolean;
begin
  z := True;
  for i := 0 to 15 do
    z := z and (Regis[i]=0);
  CheckZero := z;
end;
Procedure WriteRg;
var
  i : Word;
  j : Word;
begin
  GotoXY(1, 1);
  for i := 15 downto 0 do
   for j := 15 downto 0 do
     if (Regis[i] shr j and 1)=1 then
       Write('1') else Write('0');
end;
Function Rg(Nmb : Word) : Boolean;
begin
  Rg := Regis[(Nmb-1) shr 4] and (1 shl ((Nmb-1) and $0F)) <> 0;
end;
Procedure Generator;
begin
  l := Length(SRes);
  dec(l);
  for i := 0 to 15 do
   begin
     if i<((l+1) div 16) then Regis[i] := $FFFF;
     if i>((l+1) div 16) then Regis[i] := 0;
     if i=((l+1) div 16) then
       Regis[i] := $FFFF shr (16-((l+1) and $0F));
   end;
  inc(l);
  for i := 1 to l do
    if Rg(i) then SRes[i] := ap[i] else SRes[i] := p[i];
  WriteLn(f, SRes);
  Count := 1;
  Repeat
    if KeyPressed then Break;
    inc(Count);
    Sf := False;
    Decline(0);
    for i := 1 to l do
      if Rg(i) then SRes[i] := ap[i] else SRes[i] := p[i];
    WriteLn(f, SRes);
  Until CheckZero;
  WriteLn('---===== Итого комбинаций =====---');
  WriteLn(Count);
end;
begin
  ClrScr;
  Write('Введите имя файла для вывода комбинаций паролей: ');
  ReadLn(Fnm);
  Write('Введите первую строку: ');
  ReadLn(pp);
  Write('Введите строку с возможными изменениями: ');
  ReadLn(app);
  if Length(pp)<>Length(app) then
  begin
   WriteLn('Строки должны быть одинаковой длины!');
   Halt;
  end;
  j := 1;
  for i := 1 to Length(pp) do
   if pp[i]<>app[i] then
    begin
     p[j] := pp[i];
     ap[j] := app[i];
     Mask[i] := True;
     inc(j)
    end else Mask[i] := False;
  p[0] := Char(j-1);
  ap[0] := Char(j-1);
  NoCh:= (j-1=Length(pp));
  if Length(p)=0 then
  begin
   WriteLn('Строки не могут быть пустыми или не отличаться!');
   Halt;
  end;
  Assign(f, tmpFileName);
  Assign(fRes, Fnm);
  {$I-}
  ReWrite(fRes);
  {$I+}
  if IOResult <> 0 then
  begin
   WriteLn('Ошибка записи в файл!');
   Halt;
  end;
  ReWrite(f);
  SRes := ap;
  Generator;
  Close(f);
  if NoCh then
   begin
    Close(fRes);
    Erase(fRes);
    Rename(f, FNm);
   end
  else
 begin
  Reset(f);
  SRes[0] := Char(Length(pp));
  While not EOF(f) do
  begin
    ReadLn(f, Sap);
    j := 1;
    for i := 1 to Length(pp) do
     if Mask[i] then
      begin
        SRes[i] := Sap[j];
        inc(j);
      end else SRes[i] := pp[i];
    WriteLn(fRes, SRes);
  end;
  Close(f);
  Erase(f);
  Close(fRes);
 end;
end.

Назад