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'); 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 (*знайдено розв'язок*) OutputSolution else begin (*потрiбно пробувати*) 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.