Написание генератора кроссвордов на 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;