WA on test 25.... Please help me
type
anstype = array[0..100] of longint;
var
l : longint;
n : longint;
f : array[1..100, -100..200] of boolean;
ans : array[1..2] of anstype;
go : array[1..100, 0..100] of longint;
save : array[1..100, 0..100] of longint;
g : array[1..100, 0..100] of longint;
done : array[1..100] of boolean;
list : array[1..100, 1..2] of anstype;
que : array[1..100] of longint;
edge : array[1..100, 1..100] of boolean;
procedure init;
var
have : boolean;
i, j, a, k : longint;
hash : array[0..100] of boolean;
begin
readln(n);
fillchar(g, sizeof(g), 0);
for i := 1 to n do
begin
fillchar(hash, sizeof(hash), false);
repeat
read(a);
hash[a] := true;
until a = 0;
for j := 1 to n do
if (not hash[j]) and (i <> j)
then begin
have := false;
for k := 1 to g[i, 0] do
if g[i, k] = j
then begin
have := true;
break;
end;
if not have
then begin
inc(g[i, 0]);
g[i, g[i, 0]] := j;
end;
have := false;
for k := 1 to g[j, 0] do
if g[j, k] = i
then begin
have := true;
break;
end;
if not have
then begin
inc(g[j, 0]);
g[j, g[j, 0]] := i;
end;
end;
end;
fillchar(edge, sizeof(edge), false);
for i := 1 to n do
for j := 1 to g[i, 0] do
edge[i, g[i, j]] := true;
end;
procedure get_tree(start : longint);
var
now : array[1..100] of longint;
get_in : array[1..100] of boolean;
level : longint;
i, h, t, k, j : longint;
begin
que[1] := start;
h := 1;
t := 1;
now[1] := 1;
fillchar(get_in, sizeof(get_in), false);
get_in[start] := true;
while true do
begin
k := que[h];
level := now[h];
done[k] := true;
for i := 1 to g[k, 0] do
begin
if get_in[g[k, i]]
then continue;
inc(t);
que[t] := g[k, i];
get_in[g[k, i]] := true;
now[t] := level + 1;
end;
inc(list[l, level mod 2 + 1, 0]);
k := list[l, level mod 2 + 1, 0];
list[l, level mod 2 + 1, k] := que[h];
inc(h);
if h > t then break;
end;
for k := 1 to 2 do
for i := 1 to list[l, k, 0] do
for j := i + 1 to list[l, k, 0] do
if edge[list[l, k, i], list[l, k, j]]
then begin
writeln('No solution');
halt;
end;
end;
procedure make;
var
i : longint;
begin
l := 0;
fillchar(done, sizeof(done), false);
for i := 1 to n do
if not done[i]
then begin
inc(l);
get_tree(i);
end;
end;
procedure dp;
var
tmp : anstype;
i, t, j : longint;
begin
fillchar(f, sizeof(f), false);
f[1, abs(list[1, 1, 0] - list[1, 2, 0])] := true;
for i := 2 to l do
begin
t := abs(list[i, 1, 0] - list[i, 2, 0]);
for j := 0 to 100 do
begin
f[i, j] := f[i - 1, j - t] or f[i - 1, j + t];
if not f[i, j]
then continue;
if (f[i - 1, j - t])
then begin
save[i, j] := j - t;
go[i, j] := 2
end
else begin
save[i, j] := j + t;
go[i, j] := 1;
end
end;
end;
for i := 1 to l do
if list[i, 1, 0] < list[i, 2, 0]
then begin
tmp := list[i, 1];
list[i, 1] := list[i, 2];
list[i, 2] := tmp;
end;
end;
procedure add(a, b, c : longint);
var
tmp : anstype;
i : longint;
begin
for i := 1 to list[b, c, 0] do
ans[a, ans[a, 0] + i] := list[b, c, i];
inc(ans[a, 0], list[b, c, 0]);
if ans[1, 0] < ans[2, 0]
then begin
tmp := ans[1];
ans[1] := ans[2];
ans[2] := tmp;
end;
end;
procedure out(x, y : longint);
var
tmp : anstype;
i, t : longint;
begin
if x = 1
then begin
add(1, x, 1);
add(2, x, 2);
exit;
end;
out(x - 1, save[x, y]);
if go[x, y] = 1
then begin
add(1, x, 2);
add(2, x, 1);
end
else begin
add(1, x, 1);
add(2, x, 2);
end;
end;
procedure print;
var
i, j, t : longint;
begin
fillchar(ans, sizeof(ans), 0);
for i := 0 to 100 do
if f[l, i]
then break;
out(l, i);
for t := 1 to 2 do
begin
write(ans[t, 0]);
for i := 1 to ans[t, 0] do
write(' ', ans[t, i]);
writeln;
end;
end;
begin
init;
make;
dp;
print;
end.