Why I got WA?
Could you explain me.



There is my program:

{$I+,Q+,R+,S+}
const
  InputFile='';
  OutputFile='';
  MaxN=101;

type
  TGraph=record
    N:Integer;
    M:array[1..MaxN,1..MaxN]of Byte;
  end;
  TArrayInt=array[0..MaxN]of Integer;
  TArrayBool=array[1..MaxN]of Boolean;
  TGroup=array[1..MaxN div 2,0..MaxN]of Byte;

var
  A:TGraph;
  Kol,KolA:Integer;
  Ok:Boolean;
  Watch,UsedA:TArrayBool;
  GroupA,GroupB:TGroup;

procedure Init;
begin
  FillChar(A,SizeOf(A),0);
  FillChar(UsedA,SizeOf(UsedA),0);
  FillChar(Watch,SizeOf(Watch),0);
  FillChar(GroupA,SizeOf(GroupA),0);
  FillChar(GroupB,SizeOf(GroupB),0);
  Ok:=True;
  Kol:=0;
  KolA:=0;
end;

procedure Load;
var
  I,J:Integer;
begin
  Assign(Input,InputFile);
  ReSet(Input);
  Read(A.n);
  for i:=1 to A.n do begin
    Read(j);
    while(j>0)do begin
      A.M[i,j]:=1;
      Read(j);
    end;
  end;
  Close(Input);
end;

procedure Save;
var
  I,J:Integer;
begin
  Assign(Output,OutputFile);
  ReWrite(Output);
  if(Ok)then begin
    Write(A.n-KolA,' ');
    for i:=1 to A.n do
      if(not UsedA[i])then
        Write(i,' ');
    WriteLn;
    Write(KolA,' ');
    for i:=1 to A.n do
      if(UsedA[i])then
        Write(i,' ');
  end else
    Write('No solution');
  Close(Output);
end;

procedure GetNotFriend;
var
  I,J:Integer;
  B:TGraph;
begin
  FillChar(B,SizeOf(B),0);
  B.n:=A.n;
  for i:=1 to A.n do
    for j:=1 to A.n do
      if(A.M[i,j]=0)then begin
        B.M[i,j]:=1;
        B.M[j,i]:=1;
      end;
  for i:=1 to A.n do
    B.M[i,i]:=0;
  A:=B;
end;

procedure Paint(V:Integer);
var
  Turn,Col:TArrayInt;
  Down,Up,I:Integer;
begin
  FillChar(Turn,SizeOf(Turn),0);
  FillChar(Col,SizeOf(Col),0);
  Down:=1;
  Up:=2;
  Turn[1]:=v;
  Col[v]:=1;
  while(Down<Up)do begin
    Watch[Turn[Down]]:=True;
    for i:=1 to A.n do
      if(A.M[Turn[Down],i]>0)then
        if(Col[i]=0)then begin
          Col[i]:=(Col[Turn[Down]]-1)xor 1+1;
          Turn[Up]:=i;
          Inc(Up);
        end else
          if(Col[i]=Col[Turn[Down]])then begin
            Ok:=False;
            Exit;
          end;
    Inc(Down);
   end;
  Inc(Kol);
  for i:=1 to A.n do begin
    case(Col[i])of
      1:begin
        Inc(GroupA[Kol,0]);
        GroupA[Kol,GroupA[Kol,0]]:=i;
      end;
      2:begin
        Inc(GroupB[Kol,0]);
        GroupB[Kol,GroupB[Kol,0]]:=i;
      end;
    end;
  end;
end;

procedure FindMinGroup;
var
  I,J,K:Integer;
  P1,P2,Po,Par:TArrayInt;
begin
  FillChar(P1,SizeOf(P1),0);
  FillChar(P2,SizeOf(P2),0);
  FillChar(Po,SizeOf(Po),0);
  FillChar(Par,SizeOf(Par),0);
  p1[0]:=1;
  p2[0]:=1;
  po[0]:=1;
  for i:=1 to Kol do begin
    for j:=A.n downto GroupA[i,0] do
      if(po[j]=0)then
        if(p1[j-GroupA[i,0]]>0)then begin
          po[j]:=1;
          Par[j]:=i;
          Continue;
        end;
    for j:=A.n downto GroupB[i,0] do
      if(po[j]=0)then
        if(p2[j-GroupB[i,0]]>0)then begin
          po[j]:=2;
          Par[j]:=i;
          Continue;
        end;
    P1:=Po;
    P2:=Po;
  end;
  for i:=A.n div 2 downto 1 do
    if(po[i]>0)then begin
      j:=i;
      while(j>0)do begin
        if(Po[j]=1)then begin
          KolA:=KolA+GroupA[Par[j],0];
          for k:=1 to GroupA[Par[j],0] do
            UsedA[GroupA[Par[j],k]]:=True;
          j:=j-GroupA[Par[j],0];
        end else begin
        KolA:=KolA+GroupB[Par[j],0];
        for k:=1 to GroupB[Par[j],0] do
          UsedA[GroupB[Par[j],k]]:=True;
          j:=j-GroupB[Par[j],0];
        end;
      end;
      Exit;
    end;
end;

procedure Solve;
var
  I:Integer;
begin
  if(A.n=1)then begin
    Ok:=False;
    Exit;
  end;
  GetNotFriend;
  for i:=1 to A.n do begin
    if(not Watch[i])then begin
      Paint(i);
      if(not Ok)then
        Exit;
    end;