Đề thi Xếp số 1 trên lưới

Bài 80/2001 - Xếp số 1 trên lưới
(Dành cho học sinh THCS)
Bài toán có rất nhiều nghiệm, để liệt kê các nghiệm thì ta phải sử dụng thuật toán duyệt. Song duyệt thì rất lớn, mặt khác để ra được một cách điền thoả mãn thì không đơn giản chút nào (thời gian chạy sẽ rất lâu, thậm chí còn có thể bế tắc). Bài giải này duyệt theo một hướng tham lam có thể hiện ra được khá nhiều cách điền thoả mãn, tuy nhiên hướng giải này không hiện ra hết tất cả các nghiệm.
Hướng duyệt tham lam:
+ Mỗi dòng, mỗi cột có ít nhất một số 1.
+ Chia ma trận 10x10 thành 4 ma trận 5x5, mỗi ma trận 5x5 này sẽ được điền 4 số 1.
Cách kiểm tra tốt một ma trận sau khi điền có thoả mãn tính chất của bài không?
Duyệt cách chọn 5 hàng bất kì rồi xoá các số ở hàng đó, sau khi xoá xong ta tìm cách xoá 5 cột. Nếu sau khi xoá hàng xong mà cột nào còn số 1 thì phải xoá cột đó.
Nếu trong tất cả các cách xoá hàng, cột như vậy đều không xoá hết được thì bảng đó thoả mãn tính chất của bài.
Chương trình sau hiện ra 100 nghiệm.
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q+,R-,S+,T-,V+,X+}
{$M 16384,0,655360}
uses crt;
const N =10;
 p =16;
 sn =100; {số nghiệm muốn hiện ra}
 fo ='output.txt';
type MG =array[1..5,1..5] of byte;
var a : array[1..N,1..N] of integer;
 w : array[1..600] of MG;
 d : array[1..5] of integer;
 c,dong,cc,ddd : array[0..N] of integer;
 ok : boolean;
 dem,sl : longint;
 s : MG;
 f : text;
procedure nap;
var i,j,k : integer;
 begin
 for i:=1 to 5 do
 begin
 k:=0;
 inc(dem);
 for j:=1 to 5 do
 if ij then
 begin
 inc(k);
 w[dem,j]:=s[k];
 end;
 end;
 end;
procedure try(i:byte);
var j :byte;
 begin
 for j:=1 to 5 do
 if d[j]=0 then
 begin
 s[i,j]:=1;
 d[j]:=1;
 if i=4 then nap
 else try(i+1);
 d[j]:=0;
 s[i,j]:=0;
 end;
 end;
procedure kiemtra;
var i,j,use,k :integer;
 begin
 cc:=c;
 for i:=1 to 5 do
 for j:=1 to N do dec(cc[j],a[dong[i],j]);
 use:=0;
 for k:=1 to N do inc(use,ord(cc[k]>0));
 if use<=5 then ok:=false;
 end;
procedure thu(i:integer);
var j :integer;
 begin
 for j:=dong[i-1]+1 to N-5+i do
 begin
 dong[i]:=j;
 if i=5 then kiemtra
 else thu(i+1);
 if ok=false then exit;
 end;
 end;
procedure lam;
var i,j,x,y,u,v,k :integer;
 begin
 for i:=1 to dem do
 for j:=dem downto 1 do
 for x:=1 to dem do
 for y:=dem downto 1 do
 begin
 for u:=1 to 5 do
 for v:=1 to 5 do a[u,v]:=w[i,u,v];
 for u:=1 to 5 do
 for v:=1 to 5 do a[u,5+v]:=w[j,u,v];
 for u:=1 to 5 do
 for v:=1 to 5 do a[5+u,v]:=w[x,u,v];
 for u:=1 to 5 do
 for v:=1 to 5 do a[5+u,5+v]:=w[y,u,v];
 fillchar(c,sizeof(c),0);
 fillchar(ddd,sizeof(ddd),0);
 fillchar(dong,sizeof(dong),0);
 for u:=1 to N do
 for v:=1 to N do
 begin
 inc(c[v],a[u,v]);
 inc(ddd[u],a[u,v]);
 end;
 ok:=true;
 for k:=1 to N do
 if (c[k]=0)or(ddd[k]=0) then ok:=false;
 if ok then thu(1);
 if ok then
 begin
 inc(sl);
 writeln('*******:',sl,':*******');
 writeln(f,'*******:',sl,':*******');
 for u:=1 to N do
 begin
 for v:=1 to N do
 begin
 write(a[u,v],#32);
 write(f,a[u,v],#32);
 end;
 writeln;writeln(f);
 end;
 if sn=sl then exit;
 end;
 end;
 end;
BEGIN
 clrscr;
 fillchar(d,sizeof(d),0);
 fillchar(w,sizeof(w),0);
 fillchar(s,sizeof(s),0);
 dem:=0;sl:=0;
 try(1);
 assign(f,fo);
 rewrite(f);
 lam;
 close(f);
END.
(Lời giải của Đỗ Đức Đông)