I found an old crossword generation program in my archives that I created several years ago as a paid project for an 11th-grade student. For this reason, **many parts of the code are intentionally simplified and written amateurishly** so the student could pass it off as their own work. For the same reason, the number of words to place and answer input cells is hard-coded at 12 pieces. However, I believe that anyone who wants to improve it will have no difficulty doing so.
The program source code is supplied with extensive detailed comments, making it easy to understand the implementation details. The entire database of questions and answers is stored in the file 1.txt. If anyone decides to expand this database, they should remember to update the line Cnt=56 at the beginning.
Download the crossword generation program (Delphi 7)
Please note that this is not a finished product intended for crossword enthusiasts. The program has a very limited question database—only 56 questions—and lacks convenient controls for adjusting the crossword size and the number of questions to place.
Crossword Generation Algorithm
I developed an algorithm for selecting and placing words on the board that aims to achieve the maximum number of intersections with other words. The algorithm selects a random word and attempts to place it both horizontally and vertically, starting from the top-left corner of the board and progressing toward the bottom-right. If no intersection is found or if the word overlaps incorrectly with an already-placed word, those placements are rejected. If placement is successful, the number of intersections is recorded so we can later choose the placement with the maximum number of intersections.
When placing words, the algorithm respects certain constraints. For example, two words cannot be placed immediately adjacent to each other, otherwise it becomes unclear where one word ends and another begins.
The procedures MapWord and MapWordCheck contain the core of the word placement algorithm on the board.
procedure TMainForm.MapWord(WUindex: integer);
var
Len : integer;
x,y,n : integer;
i : integer;
cnt : integer; // Number of found placement options
POst : integer; // Remaining number of attempts to find a word from the dictionary
// Array to store possible placement variants for the word on the board
MX : array[1..Tmax*Tmax] of integer; // X coordinate on the board
MY : array[1..Tmax*Tmax] of integer; // Y coordinate on the board
MN : array[1..Tmax*Tmax] of integer; // Word direction - 1 horizontal, 2 vertical
begin // Select from dictionary and place word on board
// WUindex - ordinal number of the word being placed
POst := Pmax; // Take the specified number of attempts to select a word
cnt := 0; // Initially, the number of ways to place the word on the board is zero
while cnt=0 do begin // Loop until we find a word that can be placed at least one way
POst := POst-1; // Decrease remaining attempts
if POst1)and(T[x-1,y]<>' ')and(T[x-1,y]<>'#') then begin // word should not be placed immediately next to another word
Result := false; // Placement impossible
Exit;
end;
if (x' ')and(T[x+Len,y]<>'#') then begin // word should not be placed immediately next to another word
Result := false; // Placement impossible
Exit;
end;
for i := 1 to Len do begin // check character by character
if T[x+i-1,y]<>' ' then begin // cell is occupied
if T[x+i-1,y]<>S[i] then begin // character in cell does not match character in word - placement impossible
Result := false;
Exit;
end else begin
if (TS[x+i-1,y]=3)or(TS[x+i-1,y]=1) then begin // character matches, but there is already an intersection or a word in the same direction
Result := false; // Placement impossible
Exit;
end else begin
p := p + 1; // Register successful intersection of tested word with already-placed words
end;
end;
end;
end;
end else begin // VERTICALLY
if (y>1)and(T[x,y-1]<>' ')and(T[x,y-1]<>'#') then begin // word should not be placed immediately next to another word
Result := false; // Placement impossible
Exit;
end;
if (y' ')and(T[x,y+Len]<>'#') then begin // word should not be placed immediately next to another word
Result := false; // Placement impossible
Exit;
end;
for i := 1 to Len do begin // check character by character
if T[x,y+i-1]<>' ' then begin // cell is occupied
if T[x,y+i-1]<>S[i] then begin // character in cell does not match character in word - placement impossible
Result := false;
Exit;
end else begin
if (TS[x,y+i-1]=3)or(TS[x,y+i-1]=2) then begin // character matches, but there is already an intersection or a word in the same direction
Result := false; // Placement impossible
Exit;
end else begin
p := p + 1; // Register successful intersection of tested word with already-placed words
end;
end;
end;
end;
end;
if p>0 then begin
Result := true; // Placement with such parameters is possible
end else begin
Result := false; // Placement impossible - nothing interferes, but no intersections
end;
end;
function TMainForm.RandWord: integer;
var
r : integer;
i : integer;
begin // Select an unused word from the dictionary
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; // If the selected word is already used, reset selection to pick another
end;
end;
Result := r;
end;
procedure TMainForm.SetWord(WUindex: integer);
var
Len : integer;
S : string;
i : integer;
x,y : integer;
begin // Place word in the grid (in tables T and TS)
// WUindex - ordinal number in tables WU, WX, WY, WN (these tables must be filled beforehand)
S := W[WU[WUindex]]; // get the word
Len := Length(S); // get its length
x := WX[WUindex];
y := WY[WUindex];
// Mark cells before and after the word as occupied (so words don't stick to already-placed words)
if WN[WUindex]=1 then begin // HORIZONTALLY
if (x-1)>0 then begin // Put restriction marker before word
TS[x-1,y] := 3;
T[x-1,y] := '#';
end;
if x+Len<=Tmax then begin // Put restriction marker after word
TS[x+Len, y] :=3;
T[x+Len, y] := '#';
end;
end else begin // VERTICALLY
if (y-1)>0 then begin // Put restriction marker before word
TS[x,y-1] := 3;
T[x,y-1] := '#';
end;
if y+Len<=Tmax then begin // Put restriction marker after word
TS[x, y + Len] :=3;
T[x,y+Len] := '#';
end;
end;
for i := 1 to Len do begin
if WN[WUindex]=1 then begin // HORIZONTALLY
T[x+i-1,y] := S[i]; // Write the character
TS[x+i-1,y] := TS[x+i-1,y] + 1; // Write the code for its placement
// if (i=1) then TS[x-1,y] := 3; // Mark cell before word as occupied
end else begin // VERTICALLY
T[x,y+i-1] := S[i]; // Write the character
TS[x,y+i-1] := TS[x,y+i-1] + 2; // Write the code for its placement
end;
end;
end;