• Кроссворд
  PUZZLE
  
  Условие  Комментарии  Решение  Тестовые файлы  Оглавление

Описание
Задан набор из N слов. Слова в кроссворде должны располагаться либо вертикально, либо горизонтально, причем каждое слово, записанное по вертикали, должно пересекаться с каждым словом, записанным по горизонтали. Слова, записанные в одном направлении, отделяются друг от друга как минимум одним пустым рядом. Каждое слово в кроссворде должно встречаться в точности столько раз, сколько раз оно присутствует в наборе

Задание
Составьте связный кроссворд из предложенных слов


Входные данные
Первая строка входного файла содержит целое число N - количество слов в наборе (1≤N≤9). В каждой из N последующих строк содержится по одному слову (некоторые из них могут повторяться). Слово представляет собой последовательность не более чем из 20 русских и/или английских букв

Выходные данные
В выходной файл выведите один из возможных вариантов составления кроссворда, либо сообщение «NO SOLUTION», если кроссворд, удовлетворяющий условию задачи, составить невозможно


Например:

PUZZLE.IN
СБОРЫ
СОН
ПОТОП
АНТОН

PUZZLE.OUT
   П
 СБОРЫ
 О Т
АНТОН
   П




Решение

program puzzle;
type str30=string[20];
const TimeLimit = 330;
var n:integer;
    s:array[1..9] of str30;
    x,y,d:array[1..9] of integer;
    fbx,fby:array[-40..40] of boolean;
    hx,hy,hw:array[1..9] of integer;
    vx,vy,vw:array[1..9] of integer;
    used:array[1..9] of boolean;
    VBound,cnt,minx,maxx,miny,maxy:integer;
    tim:longint absolute $0000:$046C;
    tims:longint;
    vc,hc:integer;
function UpCas(c:char):char;
 begin
  if c = 'ё' then upCas:='Ё' else
  if c in ['a'..'z',' '..'¯'] then UpCas := char(byte(c)-32)
  else
  if c in ['а'..'я'] then UpCas := char(byte(c)-80) else upcas:=c;
 end;
 
procedure Sort(l, r: Integer);
var
  i, j: integer;
  x,y: str30;
begin
  i := l; j := r; x := s[(l+r) DIV 2];
  repeat
    while s[i] > x do i := i + 1;
    while x > s[j] do j := j - 1;
    if i <= j then
    begin
      y := s[i]; s[i] := s[j]; s[j] := y;
      i := i + 1; j := j - 1;
    end;
  until i > j;
  if l < j then Sort(l, j);
  if i < r then Sort(i, r);
end;
 
procedure ReadAll;
var i,t:integer;
    ss:str30;
 begin
  assign(input,'puzzle.in');reset(input);
   readln(n);
  for i:=1 to n do
   begin
   readln(s[i]);
    for t:=1 to length(s[i]) do s[i][t]:=upcas(s[i][t]);
   end;
  sort(1,n);
  ss:=s[1];s[1]:=s[n];s[n]:=ss;
  close(input);
 end;
 
procedure NoSol;
 begin
  writeln('NO SOLUTION');close(output);halt;
 end;
 
procedure WriteSolution;
var i,t,j:integer;
    c:char;
 begin
  inc(cnt);
  minx:=32000;maxx:=-minx;
  miny:=32000;maxy:=-miny;
  for i:=1 to hc do
   begin
    if hx[i]then minx:=hx[i];
    if hx[i]-1+length(s[hw[i]])>maxx then maxx:=hx[i]-1+length(s[hw[i]]);
   end;
  for i:=1 to vc do
   begin
    if vy[i]then miny:=vy[i];
    if vy[i]-1+length(s[vw[i]])>maxy then maxy:=vy[i]-1+length(s[vw[i]]);
   end;
  for t:=miny to maxy do
   begin
    for i:=minx to maxx do
     begin
      c:=' ';
      for j:=1 to hc do
       if (hy[j]=t) and (hx[j]<=i) and (hx[j]+length(s[hw[j]])>i) then
              c := s[hw[j]][i-hx[j]+1];
      for j:=1 to vc do
       if (vx[j]=i) and (vy[j]<=t) and (vy[j]+length(s[vw[j]])>t) then
              c := s[vw[j]][t-vy[j]+1];
      write(c);
     end;
    writeln;
   end;
  close(output);
  halt;
 end;
 
function Get(a,b,c:integer;cc:char):char;
 begin
  b:=c-b+1;
  if (b<1) or (b>length(s[a])) then Get := cc else
  get:=s[a][b];
 end;
 
procedure Pereborr(a:byte);
var i,t,j:integer;
    s1,s2:boolean;
    mins,maxs:integer;
label oblom,oblom1;
 begin
  if tim-tims>TimeLimit then NoSol;
  if a>n then begin WriteSolution;exit;end;
  if used[a] then begin Pereborr(a+1);exit;end;
 if a>VBound then
  for i:=minx to maxx do
   if not fbx[i] then
   begin
    for t:=1 downto 2-length(s[a]) do
     begin
      for j:=1 to hc do
       if Get(hw[j],hx[j],i,#1)<>get(a,t,hy[j],#2) then goto oblom;
      mins:=miny;maxs:=maxy;
      if t>miny then miny:=t;
      if t+length(s[a])-1then maxy:=t+length(s[a])-1;
      fbx[i]:=true;
      s1:=fbx[i-1];s2:=fbx[i+1];fbx[i-1]:=true;fbx[i+1]:=true;
      inc(vc);vx[vc]:=i;vy[vc]:=t;vw[vc]:=a;
      Pereborr(a+1);
      dec(vc);
      fbx[i]:=false;
      fbx[i-1]:=s1;fbx[i+1]:=s2;
      miny:=mins;maxy:=maxs;
  oblom:
     end;
    end;

  for i:=miny to maxy do
   if not fby[i] then
   begin
    for t:=vx[1] downto vx[1]-length(s[a])+1 do
     begin
      for j:=1 to vc do
       if Get(vw[j],vy[j],i,#1)<>get(a,t,vx[j],#2) then goto oblom1;
      mins:=minx;maxs:=maxx;
      if t>minx then minx:=t;
      if t+length(s[a])-1then maxx:=t+length(s[a])-1;
      fby[i]:=true;
      s1:=fby[i-1];s2:=fby[i+1];
      fby[i-1]:=true;fby[i+1]:=true;
      inc(hc);hy[hc]:=i;hx[hc]:=t;hw[hc]:=a;
      Pereborr(a+1);
      dec(hc);
      fby[i]:=false;
      fby[i-1]:=s1;fby[i+1]:=s2;
      minx:=mins;maxx:=maxs;
  oblom1:
     end;
    end;
 end;
 
procedure ATS;
var i,j,t:integer;
label 1;
 begin
  for i:=1 to n-1 do
  begin
   for t:=i+1 to n do
    begin
     for j:=1 to length(s[i]) do
     if pos(s[i][j],s[t])<>0 then goto 1;
    end;
   NoSol;
1:end;
 end;
 
procedure Solve;
var i,t,i1,i2:integer;
 begin
  vc:=1;
  hc:=1;
  fby[0]:=true;
  fby[1]:=true;
  fby[2]:=true;
   i:=1;
   begin
    used[i]:=true;
    hx[1]:=1;hy[1]:=1;hw[1]:=i;
    minx:=1;maxx:=length(s[i]);d[1]:=0;
    for t:=i+1 to n do
     begin
      VBound:=t;d[t]:=1;
      vw[1]:=t;
      used[t]:=true;
      for i1:=1 to maxx do
       for i2:=1 to length(s[t]) do
        if s[i][i1] = s[t][i2] then
         begin
          vx[1]:=i1;
          vy[1]:=2-i2;
          miny:=2-i2;
          maxy:=2-i2+length(s[t])-1;
          fbx[i1-1]:=true;
          fbx[i1]:=true;
          fbx[i1+1]:=true;
          Pereborr(2);
          fbx[i1-1]:=false;
          fbx[i1]:=false;
          fbx[i1+1]:=false;
         end;
      used[t]:=false;
     end;
    used[i]:=false;
   end;
 end;
 
begin
tims:=tim;
Assign(output,'puzzle.out');rewrite(output);
ReadAll;
ATS;
Solve;
NoSol;
end.

 

© Особенности национальных задач по информатике