Головоломка

На планете Олимпия очень популярна такая головоломка. На столе последовательно лежат N стопок разноцветных карточек. За один ход можно снять верхние карточки одного цвета с произвольного количества размещенных рядом стопок.

Задание Написать программу CARDS, которая будет вычислять минимальное количество ходов, необходимое для того, чтобы снять все карточки на столе.

Входные данные Входной текстовый файл CARDS.DAT в первой строке содержит количество стопок N2. Каждая i-я строка из последующих N строк содержит количество карточек K1 в і-й стопке и последовательность из K натуральных чисел, которые определяют цвета карточек в і-й стопке, начиная с самой нижней (1N*K10000).

Приклад входных данных.

2 2 1 2 3 3 1 2

Выходные данные Единственная строка выходного текстового файла CARDS.SOL должна содержать минимальное количество ходов T.

Пример выходных данных. 3

{$A+,B-,D-,E+,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V+,X+}

{$M 16384,0,655360}

{1<=_n<=10;1<=m<=250;}

program Template;

const MaxN=10;

MAxM=300;

type

tAr=array[1..100,1..251]of byte;

pAr=^tAr;

pL=^tL;

tL=record

id,nm:integer;

next:pl;

end;

var

fr,fw:text;

n,m,_n,p:integer;

{ ma,sa:pAr;}

ma:pAr;

sa:array[1..251] of pL;

count,num_tests:longint;

{ ca:array[0..5]of integer;}

{ sta:array[1..250]of integer; }

procedure AddList(var p:pl;a,b:integer);

var ap:pL;

begin

new(ap);

ap^.id:=a;

ap^.nm:=b;

ap^.next:=p;

p:=ap;

end;

(* procedure AnswerIsNo;

begin

{ writeln(fw,'NO');}

writeln(fw,'0');

close(fw);

close(fr);

halt;

end;*)

{ function find(r:integer;c:byte):integer;

var i,res:integer;

begin

res:=0;

for i:=1 to m do

if (sta[i]=0)and(ma^[r,i]=c) then

begin

res:=i;

break;

end;

find:=res;

end;}

procedure MultipleRow(row:integer;nm:word);

var i:integer;

ap:pL;

begin

for i:=1 to n do

ma^[i,row]:=(integer(ma^[i,row])*nm)mod p;

ap:=sa[row];

while ap<>nil do

begin

ap^.nm:=(integer(ap^.nm)*nm)mod p;

ap:=ap^.next;

end;

end;

procedure WriteList(p:pL);

begin

while p<>nil do

begin

write(p^.id,' ',p^.nm,' ');

p:=p^.next;

end;

writeln;

end;

procedure AddRows(r1,r2:integer;nm:word);

var i:integer;

ap,ap1,ap2,ap3:pL;

begin

inc(count);

{it can starts from x,not from 1 only}

for i:=1 to n do

ma^[i,r2]:=(nm*ma^[i,r1]+ma^[i,r2])mod p;

ap1:=sa[r1];

ap2:=sa[r2];

{ write(nm,' ');

writeList(ap1);

write(' ');

writeList(ap2);}

ap3:=nil;

while (ap1<>nil)and(ap2<>nil)do

begin

if ap1^.id=ap2^.id then

begin

AddList(ap3,ap1^.id,(ap2^.nm+nm*ap1^.nm)mod p);

ap1:=ap1^.next;

ap2:=ap2^.next;

end

else

if ap1^.id<ap2^.id then

begin

AddList(ap3,ap1^.id,(nm*ap1^.nm)mod p);

ap1:=ap1^.next;

end

else

begin

AddList(ap3,ap2^.id,ap2^.nm);

ap2:=ap2^.next;

end;

end;

while ap1<>nil do

begin

AddList(ap3,ap1^.id,(nm*ap1^.nm)mod p);

ap1:=ap1^.next;

end;

while ap2<>nil do

begin

AddList(ap3,ap2^.id,ap2^.nm);

ap2:=ap2^.next;

end;

ap2:=sa[r2];

while ap2<>nil do

begin

ap:=ap2;

ap2:=ap2^.next;

dispose(ap);

end;

while ap3<>nil do

begin

AddList(ap2,ap3^.id,ap3^.nm);

ap:=ap3;

ap3:=ap3^.next;

dispose(ap);

end;

sa[r2]:=ap2;

{ write(' ');

WriteList(ap2);

writeln;}

end;

procedure WriteResult;

var i:integer;

ap:pL;

begin

write(fw,'1 ');

ap:=sa[m+1];

for i:=1 to ap^.id-1 do

write(fw,'0 ');

while ap^.id<>m+1 do

begin

write(fw,ap^.nm,' ');

for i:=ap^.id+1 to ap^.next^.id-1 do

write(fw,'0 ');

ap:=ap^.next;

end;

writeln(fw);

end;

procedure CalcParameters(_n1,_n2:integer;var a,b:integer);

var n1,n2,n3,a1,b1,a2,b2,a3,b3:integer;

k:integer;

begin

a1:=1; b1:=0;

a2:=0; b2:=1;

if _n1>_n2 then

begin

n1:=_n1; n2:=_n2;

end

else

begin

n1:=_n2; n2:=_n1;

end;

while (n2>0) do

begin

n3:=n1 mod n2;

k:=n1 div n2;

a3:=a1-a2*k;

b3:=b1-b2*k;

n1:=n2; n2:=n3;

a1:=a2; a2:=a3;

b1:=b2; b2:=b3;

end;

a:=a1; b:=b1;

if a>=0 then a:=a mod p

else

begin

a:=(a+((a div p)-1)*(-p))mod p;

end;

if b>=0 then b:=b mod p

else

begin

b:=(b+((b div p)-1)*(-p))mod p;

end;

if _n1>_n2 then

else

begin

k:=a;

a:=b;

b:=k;

end;

end;

procedure Make;

var i,j,k,mpos,pos1,pos2,pos3,pos4,pos5:integer;

a,b:integer;

begin

for i:=1 to m+1 do

begin

sa[i]:=nil;

AddList(sa[i],i,1);

end;

for i:=1 to m+1 do

begin

for j:=1 to n do

read(fr,ma^[j,i]);

end;

{ fillchar(sta,sizeof(sta),0);}

for i:=1 to n do

begin

(* fillchar(ca,sizeof(ca),0);

for j:=1 to m do

if sta[j]=0 then

ca[ma^[i,j]]:=1;

if odd(ma^[i,m+1])and(ca[1]=0)and(ca[3]=0)and(ca[5]=0)then

AnswerIsNo;

if ((ma^[i,m+1] mod 3)<>0)and(ca[1]=0)and(ca[2]=0)and

(ca[4]=0)and(ca[5]=0)then

AnswerIsNo;

if (ca[1]=0)and(ca[2]=0)and(ca[3]=0)and

(ca[4]=0)and(ca[5]=0)then

if ma^[i,m+1]<>0 then

AnswerIsNo

else continue;

pos1:=find(i,1);

if pos1=0 then

begin

pos5:=find(i,5);

if pos5<>0 then

begin

MultipleRow(pos5,5);

pos1:=pos5;

end

else

begin

pos2:=find(i,2);

pos3:=find(i,3);

pos4:=find(i,4);

if pos3<>0 then

begin

if (pos2=0)and(pos4=0)then

mpos:=pos3

else

begin

if pos4=0 then

begin

MultipleRow(pos2,2);

pos4:=pos2;

end;

AddRows(pos3,pos4,1);

pos1:=pos4;

end;

end

else{ only 2s and 4s}

begin

if pos2=0 then

begin

MultipleRow(pos4,2);

pos2:=pos4;

end;

mpos:=pos2;

end;

end;

end;

if pos1<>0 then

mpos:=pos1;*)

mpos:=0;

for j:=1 to m do

if ma^[i,j]<>0 then

begin

mpos:=j;

break;

end;

if mpos=0 then

begin

if ma^[i,m+1]=0 then continue

else {AnswerIsNo;}

begin

writeln(fw,'0');

exit;

end;

end;

CalcParameters(ma^[i,mpos],p,a,b);

if a<>0 then MultipleRow(mpos,a);

for j:=mpos+1 to m do

if ma^[i,j]<>0 then

begin

CalcParameters(ma^[i,mpos],ma^[i,j],a,b);

{MultipleRow(mpos,a);}

if b<>0 then MultipleRow(j,b)

else continue;

if a<>0 then AddRows(mpos,j,a);

CalcParameters(ma^[i,j],p,a,b);

if a<>0 then MultipleRow(j,a);

mpos:=j;

if ma^[i,j]=1 then break;

end;

if (ma^[i,m+1] mod ma^[i,mpos])<>0 then

{ AnswerIsNo;}

begin

writeln(fw,'0');

exit;

end;

{ sta[mpos]:=1;}

for j:=1 to m+1 do

if {(sta[j]=0)and}(ma^[i,j]<>0)and(j<>mpos)then

AddRows(mpos,j,(p-ma^[i,j])div ma^[i,mpos]);

MultipleRow(mpos,p div ma^[i,mpos]);

end;

WriteResult;

end;

var

i,j:integer;

ap:pL;

begin

GetMem(ma,sizeof(tAr));

assign(fr,'virt.dat');

{ assign(fr,paramstr(1) + '.ori');}

reset(fr);

assign(fw,'virt.sol');

{ assign(fw,paramstr(1) + '.sol');}

rewrite(fw);

readln(fr,num_tests);

for i:=1 to num_tests do

begin

count:=0;

readln(fr,p,n,m);

{ n:=_n*_n;}

Make;

for j:=1 to 100 do

begin

while sa[i]<>nil do

begin

ap:=sa[i];

sa[i]:=sa[i]^.next;

dispose(ap);

end;

end;

end;

{ writeln(MemAvail);

writeln(MaxAvail);}

close(fr);

close(fw);

FreeMem(ma,sizeof(tAr));

end.