const MAXSZ=100;
MAXBLOCKS=40;
type LineDescript=record
N:byte;
bl_len:array[1..MAXBLOCKS] of byte;
end;
PAByte=^AByte;
AByte=array[1..MAXSZ*MAXSZ] of byte;
var pict:array[1..MAXSZ,1..MAXSZ] of byte;
Lines:array[boolean,1..MAXSZ] of LineDescript;
need_refresh:array[boolean,1..MAXSZ] of boolean;
cells:array[-1..MAXSZ] of byte;
can_one:array[-1..MAXSZ] of boolean;
can_zero:array[-1..MAXSZ] of boolean;
bl_len:array[0..MAXBLOCKS] of byte;
tb_res:array[1..MAXBLOCKS,1..MAXSZ] of shortint;
XSz,YSz:byte;
sol_found:boolean;
fout:text;
ErrorLevel:byte;
procedure Init;
var fv:text;
i,j:byte;
Begin
assign(fv,'japan.dat'); reset(fv);
readln(fv,YSz);
for i:=1 to YSz do begin
read(fv,Lines[true,i].N);
for j:=1 to Lines[true,i].N do
read(fv,Lines[true,i].bl_len[j]);
need_refresh[true,i]:=true;
readln(fv);
end;
readln(fv,XSz);
for i:=1 to XSz do begin
read(fv,Lines[false,i].N);
for j:=1 to Lines[false,i].N do
read(fv,Lines[false,i].bl_len[j]);
need_refresh[false,i]:=true;
readln(fv);
end;
close(fv);
for j:=1 to YSz do
for i:=1 to XSz do
pict[j,i]:=2;
sol_found:=false;
assign(fout,'japan.sol'); rewrite(fout);
End;
procedure AnalyzeLine(kind:boolean;number:byte);
var bl_len:array[0..MAXSZ] of byte;
N,L:byte;
function TryBlock(theblock,thestart:shortint):boolean;
var i,startnext:shortint;
res:boolean;
Begin
if (theblock>0) and (tb_res[theblock,thestart]<>-1) then begin
TryBlock:=(tb_res[theblock,thestart]=1); exit
end;
for i:=thestart to thestart+bl_len[theblock]-1 do
if cells[i]=0 then begin
tb_res[theblock,thestart]:=0;
TryBlock:=false; exit
end;
if theblock res:=false;
for startnext:=thestart+bl_len[theblock]+1 to L-bl_len[theblock+1]+1 do begin
if cells[startnext-1]=1 then break;
if TryBlock(theblock+1,startnext) then begin
res:=true;
for i:=thestart to thestart+bl_len[theblock]-1 do
can_one[i]:=true;
for i:=thestart+bl_len[theblock] to startnext-1 do
can_zero[i]:=true;
end;
end;
TryBlock:=res
end else begin (* theblock = N *)
for i:=thestart+bl_len[theblock] to L do
if cells[i]=1 then begin TryBlock:=false; exit end;
for i:=thestart to thestart+bl_len[theblock]-1 do
can_one[i]:=true;
for i:=thestart+bl_len[theblock] to L do
can_zero[i]:=true;
TryBlock:=true
end
End;
var i,j:byte;
Begin
need_refresh[kind,number]:=false;
if kind then L:=XSz else L:=YSz;
cells[-1]:=1; cells[0]:=0;
if kind then
for i:=1 to L do
cells[i]:=pict[number,i]
else
for i:=1 to L do
cells[i]:=pict[i,number];
for i:=1 to L do begin
can_one[i]:=false;
can_zero[i]:=false
end;
N:=Lines[kind,number].N;
bl_len[0]:=1;
for i:=1 to N do bl_len[i]:=Lines[kind,number].bl_len[i];
for i:=1 to N do
for j:=1 to L do
tb_res[i,j]:=-1;
if TryBlock(0,-1) then begin
for i:=1 to L do
if (cells[i]=2) and (can_one[i] xor can_zero[i]) then begin
need_refresh[not kind,i]:=true;
if can_one[i] then cells[i]:=1 else cells[i]:=0;
if kind then pict[number,i]:=cells[i]
else pict[i,number]:=cells[i];
end;
end else ErrorLevel:=1;
End;
procedure IterateLineLook;
var i:byte;
sl:boolean;
Begin
repeat
sl:=false;
for i:=1 to YSz do
if need_refresh[true,i] then begin
AnalyzeLine(true,i);
sl:=true;
end;
for i:=1 to XSz do
if need_refresh[false,i] then begin
AnalyzeLine(false,i);
sl:=true;
end;
until not sl;
End;
procedure OutputSolution;
var i,j:byte;
Begin
if sol_found then writeln(fout,'');
sol_found:=true;
for j:=1 to YSz do begin
for i:=1 to XSz do
if pict[j,i]=1 then write(fout,'*') else write(fout,'.');
writeln(fout);
end;
End;
procedure Try(y,x:byte);
var i,j,i_,j_:byte;
p:PAByte;
Begin
ErrorLevel:=0;
IterateLineLook;
if ErrorLevel<>0 then exit;
j:=y; i:=x;
while (j<=Ysz) and (pict[j,i]<>2) do
if i=XSz then begin i:=1; j:=j+1 end
else i:=i+1;
if j>YSz then (*- ©??-R аR?'пR?*)
OutputSolution
else begin (*?Rваi?-R ?аR?г? вЁ*)
GetMem(p,XSz*YSz);
for j_:=1 to YSz do
for i_:=1 to XSz do
p^[XSz*(j_-1)+i_]:=pict[j_,i_];
pict[j,i]:=0;
need_refresh[true,j]:=true; need_refresh[false,i]:=true;
Try(j,i);
for j_:=1 to YSz do
for i_:=1 to XSz do
pict[j_,i_]:=p^[XSz*(j_-1)+i_];
FreeMem(p,XSz*YSz);
pict[j,i]:=1;
need_refresh[true,j]:=true; need_refresh[false,i]:=true;
Try(j,i);
end;
End;
BEGIN
Init;
Try(1,1);
if sol_found then writeln(fout,'')
else writeln(fout,'');
close(fout);
END.
1 2
8 8 8
| 
*
Обратная связь