Написання генератора кросвордів на Delphi

Відкопав на диску у своїх архівах програму генерації кросвордів, яку кілька років тому робив на замовлення для учня 11 класу. З цієї причини навмисно багато місць у програмі спрощено й написано дилетантськи, щоб учень міг видати код за власний. Із тієї самої причини кількість розміщуваних слів і комірок для введення відповідей жорстко задана — 12. Але думаю, якщо хтось захоче це доопрацювати, буде нескладно.

Текст програми містить багато докладних коментарів, тож розібратися в деталях буде нескладно. Уся база запитань і відповідей міститься у файлі 1.txt. Якщо хтось вирішить поповнити цю базу, потрібно не забути відредагувати рядок Cnt=56 на початку.

Завантажити програму генерації кросвордів (Delphi 7)

Звертаю увагу, що це не готовий продукт для любителів кросвордів: у програмі дуже маленька база запитань — лише 56, а також немає зручного налаштування розміру кросворда та кількості розміщуваних запитань.

Алгоритм генерації кросворда

Я розробив алгоритм вибору та розміщення слів на полі, завдання якого — отримати максимальну кількість перетинів з іншими словами. Вибираючи чергове випадкове слово, алгоритм послідовно намагається розмістити його горизонтально й вертикально, поступово рухаючись від верхнього лівого кута поля до нижнього правого. Якщо немає жодного перетину або слово неправильно накладається на вже розміщене, такі варіанти відкидаються. Якщо ж розміщення визнано вдалим, запам’ятовується кількість отриманих перетинів, щоб потім вибрати варіант із найбільшою кількістю.

Під час розміщення слова алгоритм враховує певні обмеження. Наприклад, не можна розміщувати два слова одне за одним упритул, інакше буде незрозуміло, де закінчується одне й починається інше.

Процедури MapWord та MapWordCheck містять основну частину алгоритму розміщення слів на полі.

procedure TMainForm.MapWord(WUindex: integer);
var
  Len : integer;
  x,y,n : integer;
  i : integer;

  cnt : integer; // Кількість знайдених варіантів розміщення
  POst : integer; // Кількість спроб, що залишилися для добору слова зі словника
  // Масив для запам’ятовування можливих варіантів розміщення слова на полі
  MX : array[1..Tmax*Tmax] of integer; // Координата X на полі
  MY : array[1..Tmax*Tmax] of integer; // Координата Y на полі
  MN : array[1..Tmax*Tmax] of integer; // напрямок слова: 1 — горизонтально, 2 — вертикально
begin   // Вибрати зі словника та розмістити слово на полі
  // WUindex — порядковий номер розміщуваного слова

  POst := Pmax; // Беремо задану у змінній кількість спроб вибрати слово
  cnt := 0; // Спочатку кількість варіантів розміщення слова на полі = 0

  while cnt=0 do begin // повторюємо цикл, доки не знайдемо слово, яке можна розмістити хоча б одним способом
    POst := POst-1; // Зменшуємо кількість спроб, що залишилися
    if POst1)and(T[x-1,y]<>' ')and(T[x-1,y]<>'#') then begin // слово не повинно прилягати впритул до іншого слова
      Result := false; // розміщення неможливе
      Exit;
    end;
    if (x<Tmax)and(T[x+Len,y]<>' ')and(T[x+Len,y]<>'#') then begin // слово не повинно прилягати впритул до іншого слова
      Result := false; // розміщення неможливе
      Exit;
    end;

    for i := 1 to Len do begin // перевіряємо символ за символом
      if T[x+i-1,y]<>' ' then begin // комірка чимось зайнята
        if T[x+i-1,y]<>S[i] then begin // символ у комірці не збігається із символом у слові — розміщення неможливе
          Result := false;
          Exit;
        end else begin
          if (TS[x+i-1,y]=3)or(TS[x+i-1,y]=1) then begin // символ збігся, але тут уже є перетин слів або слово, розміщене в тому самому напрямку
            Result := false; // розміщення неможливе
            Exit;
          end else begin
            p := p + 1; // реєструємо вдалий перетин перевірюваного слова з уже розміщеними
          end;
        end;
      end;
    end;
  end else begin // ВЕРТИКАЛЬНО
    if (y>1)and(T[x,y-1]<>' ')and(T[x,y-1]<>'#') then begin // слово не повинно прилягати впритул до іншого слова
      Result := false; // розміщення неможливе
      Exit;
    end;
    if (y<Tmax)and(T[x,y+Len]<>' ')and(T[x,y+Len]<>'#') then begin // слово не повинно прилягати впритул до іншого слова
      Result := false; // розміщення неможливе
      Exit;
    end;

    for i := 1 to Len do begin // перевіряємо символ за символом
      if T[x,y+i-1]<>' ' then begin // комірка чимось зайнята
        if T[x,y+i-1]<>S[i] then begin // символ у комірці не збігається із символом у слові — розміщення неможливе
          Result := false;
          Exit;
        end else begin
          if (TS[x,y+i-1]=3)or(TS[x,y+i-1]=2) then begin // символ збігся, але тут уже є перетин слів або слово, розміщене в тому самому напрямку
            Result := false; // розміщення неможливе
            Exit;
          end else begin
            p := p + 1; // реєструємо вдалий перетин перевірюваного слова з уже розміщеними
          end;
        end;
      end;
    end;
  end;
  if p>0 then begin
    Result := true; // розміщення з такими параметрами можливе
  end else begin
    Result := false; // розміщення неможливе: нічого не заважає, але й перетинів немає
  end;
end;

function TMainForm.RandWord: integer;
var
  r : integer;
  i : integer;
begin // Вибираємо зі словника слово, яке ще не використано
  r := 0;
  while r=0 do begin
    r := 1 + Random(wCnt-1);
    for i := 1 to WUmax do begin
      if WU[i]=r then r := 0; // Якщо вибране слово вже використано, скидаємо вибір, щоб узяти інше
    end;
  end;
  Result := r;
end;

procedure TMainForm.SetWord(WUindex: integer);
var
  Len : integer;
  S : string;
  i : integer;
  x,y : integer;
begin // Вписуємо слово в сітку (у таблиці T та TS)
// WUindex — його порядковий номер у таблицях WU, WX, WY, WN (ці таблиці потрібно заповнити заздалегідь)
  S := W[WU[WUindex]]; // отримуємо слово
  Len := Length(S); // отримуємо його довжину
  x := WX[WUindex];
  y := WY[WUindex];
  // позначаємо комірки перед словом і після нього як зайняті (щоб слова своїм початком або кінцем не прилягали впритул до вже розміщених)
  if WN[WUindex]=1 then begin // ГОРИЗОНТАЛЬНО
    if (x-1)>0 then begin // Ставимо обмежувальний знак перед словом
      TS[x-1,y] := 3;
      T[x-1,y] := '#';
    end;
    if x+Len<=Tmax then begin // Ставимо обмежувальний знак після слова
      TS[x+Len, y] :=3;
      T[x+Len, y] := '#';
    end;
  end else begin // ВЕРТИКАЛЬНО
    if (y-1)>0 then begin // Ставимо обмежувальний знак перед словом
      TS[x,y-1] := 3;
      T[x,y-1] := '#';
    end;
    if y+Len<=Tmax then begin // Ставимо обмежувальний знак після слова
      TS[x, y + Len] :=3;
      T[x,y+Len] := '#';
    end;
  end;

  for i := 1 to Len do begin
    if WN[WUindex]=1 then begin // ГОРИЗОНТАЛЬНО
      T[x+i-1,y] := S[i];             // Вписуємо символ
      TS[x+i-1,y] := TS[x+i-1,y] + 1; // Вписуємо кодове позначення його розташування
// if (i=1) then TS[x-1,y] := 3; // позначаємо комірку перед словом як зайняту
    end else begin // ВЕРТИКАЛЬНО
      T[x,y+i-1] := S[i];    // Вписуємо символ
      TS[x,y+i-1] := TS[x,y+i-1] + 2; // Вписуємо кодове позначення його розташування
    end;
  end;
end;