uses SysUtils;
type
  AYFYears = record
   Body:string;
   Question:boolean;
  end;
  AYFPlace = record
   Body,Comment:string;
   Question:boolean;
  end;
  AYFBirthday = record
   Body:string;
   Question:boolean;
  end;
  AYFGroup = record
   Body,Comment:string;
   Question:boolean;
  end;
  AYFGroups = array of AYFGroup;
  AYFName = record
   Intro,Body,Outro,Comment:string;
   PrefSpace,SufSpace,Question:boolean;
   Groups:AYFGroups;
  end;
  AYFRealName = record
   F1stName,FLastName:string;
   F2ndNames:array of string;
  end;
var
    Base:array of record
     New,Fixed:boolean;
     Names:array of AYFName;
     RealName:AYFRealName;
     PCName:string;
     Birthday:AYFBirthday;
     Place:AYFPlace;
     Years:AYFYears;
     Comment,LastLabel:string;
    end;
    blen:integer;

    Base2:array of record
     Names,Groups,Places:array of string;
     FIO,Years:string;
     Diff,Checked:boolean;
    end;
    blen2:integer;
    sokr:array of record
     abbr,name:string;
    end;
    sokrlen:integer;

procedure RemoveYo(var s:string);
var
 i:integer;
begin
for i := 1 to Length(s) do
 if s[i] = '¸' then s[i] := 'å';
end;

procedure LoadBases;
var
 s:string;
 
 function GetStr:string;
 var
  i,l:integer;
 begin
 i := Pos(#9,s);
 if i = 0 then
  begin
   Result := s;
   s := '';
  end
 else
  begin
   if i > 1 then
    Result := Copy(s,1,i - 1)
   else
    Result := '';
   l := Length(s);
   if i < l then
    s := Copy(s,i + 1,l - i)
   else
    s := '';
  end;
 RemoveYo(Result);
 end;

 procedure InterpLine(n:integer);

 var
  l,i,j:integer;
 begin
  with Base[n] do
   begin
    New := GetStr <> '';
    Fixed := GetStr <> '';
    l := StrToInt(GetStr);
    SetLength(Names,l);
    for i := 0 to l - 1 do
     with Names[i] do
      begin
       Intro := GetStr;
       PrefSpace := GetStr <> '';
       Body := GetStr;
       SufSpace := GetStr <> '';
       Outro := GetStr;
       Question := GetStr <> '';
       Comment := GetStr;
       l := StrToInt(GetStr);
       SetLength(Groups,l);
       for j := 0 to l - 1 do
       with Groups[j] do
        begin
         Body := GetStr;
         Question := GetStr <> '';
         Comment := GetStr;
        end;
      end;
    with RealName do
     begin
      FLastName := GetStr;
      F1stName := GetStr;
      l :=  StrToInt(GetStr);
      SetLength(F2ndNames,l);
      for i := 0 to l - 1 do
       F2ndNames[i] := GetStr;
     end;
    PCName := GetStr;
    with Birthday do
     begin
      Body := GetStr;
      Question := GetStr <> '';
     end;
    with Place do
     begin
      Body := GetStr;
      Question := GetStr <> '';
      Comment := GetStr;
     end;
    Comment := GetStr;
    with Years do
     begin
      Body := GetStr;
      Question := GetStr <> '';
     end;
    LastLabel := GetStr;
   end;
 end;

 procedure InterpSLine(n:integer);
 begin
 sokr[n].abbr := GetStr;
 sokr[n].name := GetStr;
 end;

var
 f:TextFile;
begin
sokrlen := 0;
AssignFile(f,'Sokr.txt');
Reset(f);
while not eof(f) do
 begin
  if sokrlen and 1023 = 0 then SetLength(sokr,sokrlen + 1024);
  Readln(f,s);
  InterpSLine(sokrlen);
  inc(sokrlen);
 end;
CloseFile(f);
SetLength(sokr,sokrlen);

blen := 0;
AssignFile(f,'..\Base\base.txt');
Reset(f);
while not eof(f) do
 begin
  if blen and 1023 = 0 then SetLength(Base,blen + 1024);
  Readln(f,s);
  InterpLine(blen);
  inc(blen);
 end;
CloseFile(f);
SetLength(Base,blen);
end;

function InterpLine2(s:string;n:integer; var Mode:integer):boolean;
var
 name:string;
 l,b,i,ypos:integer;
begin
Result := False;
if Mode < 0 then exit;
s := Trim(s); if s = '' then exit;
if s = '[new generation, russians, nickname]' then
 begin
  Mode := 0;
  exit;
 end;
if s = '[new generation, russians, fullname]' then
 begin
  Mode := 1;
  exit;
 end;
if s = '[new generation, europeans, nickname]' then
 begin
  Mode := 2;
  exit;
 end;
if s = '[old generation] [b] - only beeper' then
 begin
  Mode := 3;
  exit;
 end;
if s[1] = '[' then exit;
if Pos('-------------------------------------',s) = 1  then exit;
if Pos('???',s) = 1  then
 begin
  Mode := -1;
  exit;
 end;
l := Length(s);
if (l > 3) and (s[l] in ['!','?'])
           and (s[l-1] in ['!','?'])
           and (s[l-2] in ['!','?']) then SetLength(s,l-3);
l := Length(s);
if (l > 3) and (s[l] in [']'])
           and (s[l-1] in ['b'])
           and (s[l-2] in ['[']) then SetLength(s,l-3);
l := Length(s);
Base2[n].FIO := '';
Base2[n].Years := '';
Base2[n].Diff := True;
Base2[n].Checked := False;
case Mode of
0: ypos := 63;
3: ypos := 48;
else  ypos := 53;
end;
RemoveYo(s);
case Mode of
0,2:
 begin
  i := 1;
  name := '';
  while (i <= l) and (i < ypos) and not (s[i] in ['/','(']) do
   begin
    name := name + s[i];
    inc(i);
   end;
  name := Trim(name); if name <> '' then
   begin
    b := Length(Base2[n].Names);
    SetLength(Base2[n].Names,b + 1);
    Base2[n].Names[b] := name;
   end;
  if (i <= l) and (i < ypos) and (s[i] = '/') then
   begin
    name := '';
    inc(i);
    while (i <= l) and (i < ypos) and not (s[i] in ['(']) do
     begin
      name := name + s[i];
      inc(i);
     end;
    name := Trim(name); if name <> '' then
     begin
      b := Length(Base2[n].Groups);
      SetLength(Base2[n].Groups,b + 1);
      Base2[n].Groups[b] := name;
     end;
   end;
  if (i <= l) and (i < ypos) and (s[i] = '(') then
   repeat
    name := '';
    inc(i);
    while (i <= l) and (i < ypos) and not (s[i] in [',',')']) do
     begin
      name := name + s[i];
      inc(i);
     end;
    name := Trim(name);
    if (i <= l) and (i < ypos) and (s[i] = ',') then
     begin
      if name <> '' then
       begin
        b := Length(Base2[n].Groups);
        SetLength(Base2[n].Groups,b + 1);
        Base2[n].Groups[b] := name;
       end;
     end
    else
     begin
      Base2[n].FIO := name;
      break;
     end;
   until False;
  i := ypos;
  name := '';
  while (i <= l) and (s[i] <> ' ') do
   begin
    name := name + s[i];
    inc(i);
   end;
  name := Trim(name);
  Base2[n].Years := name;
  repeat
   name := '';
   inc(i);
   while (i <= l) and (s[i] <> '/') do
    begin
     name := name + s[i];
     inc(i);
    end;
   name := Trim(name); if name <> '' then
    begin
     b := Length(Base2[n].Places);
     SetLength(Base2[n].Places,b + 1);
     Base2[n].Places[b] := name;
    end;
  until i > l;
  Result := True;
 end;
1:
 begin
  i := 1;
  name := '';
  while (i <= l) and (i < ypos) and not (s[i] in ['/','(']) do
   begin
    name := name + s[i];
    inc(i);
   end;
  Base2[n].FIO := Trim(name);
  if (i <= l) and (i < ypos) and (s[i] = '/') then
   begin
    name := '';
    inc(i);
    while (i <= l) and (i < ypos) and not (s[i] in ['(']) do
     begin
      name := name + s[i];
      inc(i);
     end;
    name := Trim(name); if name <> '' then
     begin
      b := Length(Base2[n].Groups);
      SetLength(Base2[n].Groups,b + 1);
      Base2[n].Groups[b] := name;
     end;
   end;
  i := ypos;
  name := '';
  while (i <= l) and (s[i] <> ' ') do
   begin
    name := name + s[i];
    inc(i);
   end;
  name := Trim(name);
  Base2[n].Years := name;
  repeat
   name := '';
   inc(i);
   while (i <= l) and (s[i] <> '/') do
    begin
     name := name + s[i];
     inc(i);
    end;
   name := Trim(name); if name <> '' then
    begin
     b := Length(Base2[n].Places);
     SetLength(Base2[n].Places,b + 1);
     Base2[n].Places[b] := name;
    end;
  until i > l;
  Result := True;
 end;
3:
 begin
  i := 1;
  name := '';
  while (i <= l) and (i < ypos) and not (s[i] in ['(']) do
   begin
    name := name + s[i];
    inc(i);
   end;
  Base2[n].FIO := Trim(name);
  if (i <= l) and (i < ypos) and (s[i] = '(') then
   begin
    name := '';
    inc(i);
    while (i <= l) and (i < ypos) and not (s[i] in [')']) do
     begin
      name := name + s[i];
      inc(i);
     end;
    name := Trim(name); if name <> '' then
     begin
      b := Length(Base2[n].Names);
      SetLength(Base2[n].Names,b + 1);
      Base2[n].Names[b] := name;
     end;
   end;
  i := ypos;
  name := '';
  while (i <= l) and (s[i] <> ' ') do
   begin
    name := name + s[i];
    inc(i);
   end;
  name := Trim(name);
  Base2[n].Years := name;
  repeat
   name := '';
   inc(i);
   while (i <= l) and (s[i] <> '/') do
    begin
     name := name + s[i];
     inc(i);
    end;
   name := Trim(name); if name <> '' then
    begin
     b := Length(Base2[n].Places);
     SetLength(Base2[n].Places,b + 1);
     Base2[n].Places[b] := name;
    end;
  until i > l;
  Result := True;
 end;
end;
end;

procedure CompareLine(n:integer);
var
 ll:integer;
 s,s3:string;
 FoundStrs:array of integer;
 LenFS,LenFS2:integer;

 function GetFIO(n:integer;rus:boolean):string;
 var
  i,l:integer;
  s1,s2,s3,sp:string;
 begin
  Result := '';
  s1 := Base[n].RealName.FLastName;
  s2 := Base[n].RealName.F1stName;
  s3 := ''; l := Length(Base[n].RealName.F2ndNames) - 1;
  for i := 0 to l do
   begin
    s3 := s3 + Base[n].RealName.F2ndNames[i];
    if i < l then s3 := s3 + ' ';
   end;
  if not rus then
   begin
    sp := s1; s1 := s2; s2 := s3; s3 := sp;
   end;
  sp := ''; if (s1 <> '') and (s2 <> '') then sp := ' ';
  s1 := s1 + sp + s2;
  sp := ''; if (s1 <> '') and (s3 <> '') then sp := ' ';
  Result := AnsiUpperCase(s1 + sp + s3);
 end;

 function GetName(n,k:integer):string;
 begin
 Result := Base[n].Names[k].Intro;
 if (Result <> '') and (Base[n].Names[k].PrefSpace) then Result := Result + ' ';
 Result := Result + Base[n].Names[k].Body;
 if (Result <> '') and (Base[n].Names[k].Outro <> '') and (Base[n].Names[k].SufSpace) then Result := Result + ' ';
 Result := AnsiUpperCase(Result + Base[n].Names[k].Outro);
 end;

 function FindSokr(s:string;n:integer):string;
 var
  i:integer;
 begin
 Result := '';
 case n of
 0:
  for i := 0 to sokrlen - 1 do
   if Pos(s,AnsiUpperCase(sokr[i].abbr)) = 1 then
    begin
     Result := AnsiUpperCase(sokr[i].name);
     exit;
    end;
 1:
  for i := 0 to sokrlen - 1 do
   if Pos(s,AnsiUpperCase(sokr[i].name)) = 1 then
    begin
     Result := AnsiUpperCase(sokr[i].abbr);
     exit;
    end;
 end;
 end;

procedure CompareGrPlYr;
var
 i,j,k,l:integer;
 f:boolean;
begin
ll := Length(Base2[n].Groups);
for j := 0 to ll - 1 do
 begin
  s := AnsiUpperCase(Base2[n].Groups[j]);
  LenFS2 := 0;
  for i := 0 to LenFS - 1 do
   for k := 1 to Length(Base[FoundStrs[i]].Names) - 1 do
    begin
     f := false;
     for l := 0 to Length(Base[FoundStrs[i]].Names[k].Groups) - 1 do
      begin
       s3 := AnsiUpperCase(Base[FoundStrs[i]].Names[k].Groups[l].Body);
       if (Pos(s,s3) = 1) or (Pos(s,FindSokr(s3,0)) = 1) or (Pos(s,FindSokr(s3,1)) = 1)  then
        begin
         FoundStrs[LenFS2] := FoundStrs[i];
         inc(LenFS2);
         f := true;
         break;
        end;
      end;
     if f then break;
    end;
  if LenFS2 = 0 then exit;
  LenFS := LenFS2;
 end;

ll := Length(Base2[n].Places);
for j := 0 to ll - 1 do
 begin
  s := AnsiUpperCase(Base2[n].Places[j]);
  if s = 'ÑÀÍÊÒ-ÏÅÒÅÐÁÓÐÃ' then s := 'ÑÏÁ';
  if (j > 0) and ((s = 'ÓÊÐÀÈÍÀ') or (s = 'ÁÅËÀÐÓÑÜ')) then continue;
  LenFS2 := 0;
  for i := 0 to LenFS - 1 do
   if Pos(s,AnsiUpperCase(Base[FoundStrs[i]].Place.Body)) <> 0 then
    begin
     FoundStrs[LenFS2] := FoundStrs[i];
     inc(LenFS2);
    end;
  if LenFS2 = 0 then exit;
  LenFS := LenFS2;
 end;

s := AnsiUpperCase(Base2[n].Years);
if s <> '' then
 begin
  LenFS2 := 0;
  for i := 0 to LenFS - 1 do
   if Pos(s,AnsiUpperCase(Base[FoundStrs[i]].Years.Body)) <> 0 then
    begin
     FoundStrs[LenFS2] := FoundStrs[i];
     inc(LenFS2);
    end;
  if LenFS2 = 0 then exit;
  LenFS := LenFS2;
 end;

Base2[n].Diff := LenFS <> 1;

end;

procedure CompareLineName;
var
 i,j,k:integer;
begin
if Base2[n].Checked then exit;
ll := Length(Base2[n].Names);
if ll = 0 then exit;
LenFS := 0;
for j := 0 to ll - 1 do
 begin
  s := AnsiUpperCase(Base2[n].Names[j]);
  for i := 0 to blen - 1 do
   for k := 1 to Length(Base[i].Names) - 1 do
    if Pos(s,GetName(i,k)) = 1 then
     begin
      FoundStrs[LenFS] := i;
      inc(LenFS);
      break
     end;
 end;
if LenFS = 0 then exit;

CompareGrPlYr;

end;

procedure CompareLineFIO;
var
 i,j,k:integer;
begin
LenFS := 0;
{if length(Base2[n].Names) <> 0 then
 if Base2[n].Names[0] = 'Andy Fer' then
  Base2[n].Names[0] := 'Andy Fer';}
s := AnsiUpperCase(Base2[n].FIO);
if s = '' then exit;
Base2[n].Checked := True;
for i := 0 to blen - 1 do
 if (Pos(s,GetFIO(i,False)) = 1) or (Pos(s,GetFIO(i,True)) = 1) then
  begin
   FoundStrs[LenFS] := i;
   inc(LenFS)
  end;
if LenFS = 0 then exit;

ll := Length(Base2[n].Names);
for j := 0 to ll - 1 do
 begin
  LenFS2 := 0;
  s := AnsiUpperCase(Base2[n].Names[j]);
  for i := 0 to LenFS - 1 do
   for k := 1 to Length(Base[FoundStrs[i]].Names) - 1 do
    if Pos(s,GetName(FoundStrs[i],k)) = 1 then
     begin
      FoundStrs[LenFS2] := FoundStrs[i];
      inc(LenFS2);
      break;
     end;
  if LenFS2 = 0 then exit;
  LenFS := LenFS2;
 end;

CompareGrPlYr;

end;

begin
SetLength(FoundStrs,blen);
CompareLineFIO;
CompareLineName;
end;

var
 f:TextFile;
 s:string;
 Mode,l,i,j:integer;
begin
LoadBases;
blen2 := 0;
AssignFile(f,'..\Archive\Nv0.17.txt');
Reset(f);
Readln(f);
Mode := 0;
while not eof(f) do
 begin
  if blen2 and 1023 = 0 then SetLength(Base2,blen2 + 1024);
  Readln(f,s);
  if InterpLine2(s,blen2,Mode) then inc(blen2);
 end;
CloseFile(f);
SetLength(Base2,blen2);

AssignFile(f,'result.txt');
Rewrite(f);
for i := 0 to blen2 - 1 do
 begin
  CompareLine(i);
  s := #9; if Base2[i].Diff then s := '!'#9;
  l := Length(Base2[i].Names) - 1;
  for j := 0 to l do
   begin
    s := s + Base2[i].Names[j];
    if j < l then s := s + ',';
   end;
  s := s + #9; 
  l := Length(Base2[i].Groups) - 1;
  for j := 0 to l do
   begin
    s := s + Base2[i].Groups[j];
    if j < l then s := s + ',';
   end;
  s := s + #9 + Base2[i].FIO + #9 + Base2[i].Years + #9;
  l := Length(Base2[i].Places) - 1;
  for j := 0 to l do
   begin
    s := s + Base2[i].Places[j];
    if j < l then s := s + ',';
   end;
  Writeln(f,s);
 end;
CloseFile(f);
Beep;
end.
