Как написать программу для решения японского кроссворда

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<N then begin
      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,'<next>');
  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,'<end>')
               else writeln(fout,'<no solutions>');
  close(fout);
END.