+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: Magdha/Qwerky (https://qb64phoenix.com/forum/forumdisplay.php?fid=69)
+---- Thread: Four Crossword Programs (One for Crossword Fanatics) (/showthread.php?tid=4327)
Four Crossword Programs (One for Crossword Fanatics) - Magdha - 01-13-2026
This thread contains four programs for crosswords.
(It's a particular interest of Magdha).
(It's a particular interest of Magdha).
Four Crossword Programs.zip (Size: 9.86 MB / Downloads: 5)
Multilingual Crossword Generator
This program generates a crossword from scratch. Firstly it fills a 15x15 grid with blank squares with 2-fold symmetry (standard crossword). It then places words in the grid until it either completes the crossword or starts again and cycles until a satisfactory crossword is produced. The program is multilingual and will use from 7 dictionaries - UK English (default), US English, German, Spanish, French, Italian or Dutch.
When the program starts, you choose your language - Spacebar to cycle the language options and Enter to select. The program will generate a grid and begin to add words slowly entry-by-entry until it completes the crossword or stops and shows a position that cannot be completed. Spacebar to try again. When the program stops, you can press 'f' to change to rapid mode where the computer finds a complete crossword as quickly as possible.
The processor is doing a lot of calculations when trying to complete the grid, and I did make a _MEM object processing version to improve speed, but this is the original.
The first screenshot shows a failed attempt to complete a grid, whilst the second shows a completed grid (UK English).
Crossword Maker
This is a program for crossword compilers. You create a standard 2-fold symmetry 15x15 crossword grid, and fill it with words and blanks. The output is two grids - one with the completed grid as the solution, and one with the grid with numbered squares for setting the puzzle. The screen grids can be used for setting in a document as required.
This is an InForm project which uses 235 InForm objects (the QB64PE record?) - 225 TextBoxes plus 10 others.
The grid is created using Crossword Maker.bas (InForm). In the array of 15x15 TextBoxes, you place either a letter of a blank (Spacebar). The program will force the usual 2-fold symmetry. When the grid is complete, this is saved and used by the program Draw Completed Grid.bas to output the starting and completed grids to the screen. PrtScn to copy to clipboard to save as image files.
10+225 InForm objects
The first screenshot shows a grid partially completed (notice the 225 TextBoxes!), the second is the completed grid output.
Cipher Crossword Generator
The Cipher Crossword Generator creates a 15x15 crossword grid and fills the grid with words (normal crossword rules) using every letter of the alphabet at least once. The words are filled in using the uncommon letters first so as to give the best chance of allowing all the words to intersect properly. The program will cycle until it can complete a grid. This program is a specialised version of and uses many techniques of the Crossword Generator.
The screenshot shows a completed grid which took 0.1s to complete on a Corei5 Laptop.
Cipher Crossword Puzzle
In the program you have to solve a Cipher Crossword by working out which letters go in which places. All the letters of the alphabet are used. This is a standard crossword puzzle type. If you wish to try it, you will probably need to read the User Manual.
When you first use the program, there is a routine to determine which mouse button you use. During the game letters are moved in 3D space, implemented by _MAPTRIANGLE(3D).
Cipher Crossword Puzzle User Manual.pdf (Size: 279.96 KB / Downloads: 8)
The video shows how the letters are moved to and from the grid.
For completeness the .bas files are given here:
Multilingual Crossword Generator
Code: (Select All)
'Multilingual Crossword Generator by Magdha 2026-01-11 ex Qwerkey
'When program starts select your language - Spacebar to change, Enter to select
'At first the program slowly fill the grid word-by-word
'Spacebar for another try or 'f' to change to rapid mode where the program will evetually find a complete grid
'Esc to Quit
CONST False = 0, True = NOT False, MaxTries& = 14000 'The best compromise for all languages
DIM LesLettres&(26), Orient%%(1, 1), ULoc$(6), FillOrder%%(6), LangImg&(6), RndCount&(6)
_TITLE "Crossword Generator"
RESTORE OrientFill
FOR D%% = 0 TO 1
READ Orient%%(D%%, 0)
READ Orient%%(D%%, 1)
NEXT D%%
FOR N%% = 0 TO 6
READ FillOrder%%(N%%)
NEXT N%%
'Menu Screens
LangImg&(0) = _LOADIMAGE("UKEnglish.jpg", 32)
LangImg&(1) = _LOADIMAGE("USEnglish.jpg", 32)
LangImg&(2) = _LOADIMAGE("Deutsch.jpg", 32) '
LangImg&(3) = _LOADIMAGE("Espanol.jpg", 32)
LangImg&(4) = _LOADIMAGE("Francais.jpg", 32)
LangImg&(5) = _LOADIMAGE("Roman.jpg", 32)
LangImg&(6) = _LOADIMAGE("Nederlands.jpg", 32)
LangChosen%% = False
OPEN "xword.cfg" FOR INPUT AS #1
INPUT #1, Language%%
CLOSE #1
SELECT CASE Language%%
CASE 0 'UK English (Default)
_TITLE "Crossword Generator"
CASE 1 'US English
_TITLE "Crossword Generator"
CASE 2 'German
_TITLE "Kreuzwortratselgenerator"
CASE 3 'Spanish
_TITLE "Generador de Crucigramas"
CASE 4 'French
_TITLE "Generateur de Mots Croises"
CASE 5 'Italian
_TITLE "Generatore di Cruciverba"
CASE ELSE 'Dutch
_TITLE "Kruiswoordpuzzelgenerator "
END SELECT
'NonMid$: Letters excluded from middle crossings
'NonEnd$: Letters excluded from end crossings
'Select Language
SCREEN _NEWIMAGE(301, 501, 32)
_DEST 0
_PUTIMAGE , LangImg&(Language%%)
WHILE NOT LangChosen%%
_LIMIT 30
k$ = INKEY$
IF k$ <> "" THEN
IF k$ = " " THEN
Language%% = Language%% + 1
IF Language%% > 6 THEN Language%% = 0
CLS
_PUTIMAGE , LangImg&(Language%%)
ELSEIF ASC(k$) = 13 THEN
LangChosen%% = True
ELSEIF ASC(k$) = 27 THEN
SYSTEM
END IF
k$ = ""
END IF
WEND
OPEN "xword.cfg" FOR OUTPUT AS #1
PRINT #1, Language%%
CLOSE #1
MaxCount& = 0
SELECT CASE Language%%
CASE 0 'UK English (Default)
NonMid$ = "BFJKQVWXYZ"
NonEnd$ = "BCFGHIJKMOPQUVWXZ"
Rouge% = 235
Vert% = 0
Bleu% = 0
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "UKEng.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Crossword Generator"
CASE 1 'US English
NonMid$ = "BFJKQVWXYZ"
NonEnd$ = "BCFGHIJKMOPQUVWXZ"
Rouge% = 41
Vert% = 46
Bleu% = 139
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "USEng.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Crossword Generator"
CASE 2 'German
NonMid$ = "FJKMPQVWXYZ" 'K is nearly acceptable
NonEnd$ = "ABCFHIJLOPQUVWXZ" 'A is high for <= 6 low for >= 7, G is high for >= 6 low for <= 5
Rouge% = 120
Vert% = 100
Bleu% = 0
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "deutsch.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Kreuzwortratselgenerator"
CASE 3 'Spanish
NonMid$ = "FHJKPQVWXYZ"
NonEnd$ = "BCDFGHIJKLMPQTUVWYXZ"
Rouge% = 185
Vert% = 2
Bleu% = 31
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "palabras.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Generador de Crucigramas"
CASE 4 'French
NonMid$ = "BFHJKQVWXYZ"
NonEnd$ = "BCDFGHJKLMNOPQUVWX"
Rouge% = 110
Vert% = 0
Bleu% = 110
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "mots.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Generateur de Mots Croises"
CASE 5 'Italian
NonMid$ = "FHJKQWXY"
NonEnd$ = "BCDFGHJKLMNPQSUVWXZ" 'R/T doubtful
Rouge% = 0
Vert% = 215
Bleu% = 0
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "ita.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Generatore di Cruciverba"
CASE ELSE 'Dutch
NonMid$ = "BCFGHJKMPQVWXYZ" 'G is low for <= 7, J&K nearly acceptable, S is low for 4
NonEnd$ = "BCFGHIJMOPQUVWXZ" 'A is high for <= 5
Rouge% = 215
Vert% = 130
Bleu% = 0
'Open Dictionaries
FOR K%% = 4 TO 10
OPEN LTRIM$(STR$(K%%)) + "ned.rnd" FOR RANDOM AS #K%% LEN = K%%
FIELD #K%%, K%% AS ULoc$(K%% - 4)
RndCount&(K%% - 4) = LOF(K%%) / K%%
IF RndCount&(K%% - 4) > MaxCount& THEN MaxCount& = RndCount&(K%% - 4)
NEXT K%%
_TITLE "Kruiswoordpuzzelgenerator "
END SELECT
DIM Alphabet$(6, MaxCount&)
FOR K%% = 4 TO 10
FOR Counter& = 1 TO RndCount&(K%% - 4)
GET #K%%, Counter&
Alphabet$(K%% - 4, Counter&) = ULoc$(K%% - 4)
NEXT Counter&
CLOSE #K%%
NEXT K%%
'Character Images
RESTORE CharOffset
FOR N%% = 1 TO 26
READ CyberSpace%%
LesLettres&(N%%) = _NEWIMAGE(34, 34, 32)
_DEST LesLettres&(N%%)
COLOR _RGB32(Rouge%, Vert%, Bleu%), _RGB32(255, 255, 255)
CLS
F& = _LOADFONT("cyberbit.ttf", 30, "bold")
_FONT F&
_PRINTSTRING (CyberSpace%%, 0), CHR$(N%% + 64)
_FONT 16
_FREEFONT F&
NEXT N%%
LesLettres&(0) = _NEWIMAGE(34, 34, 32)
_DEST LesLettres&(0)
COLOR _RGB32(Rouge%, Vert%, Bleu%), _RGB32(255, 255, 255)
CLS
F& = _LOADFONT("cyberbit.ttf", 30, "bold")
_FONT F&
_PRINTSTRING (6, 4), "*"
_FONT 16
_FREEFONT F&
'Crossword Screen
SCREEN _NEWIMAGE(800, 800, 32)
_SCREENMOVE 50, 10
_DEST 0
DoXWord%% = True
SloMo%% = True
WHILE DoXWord%%
'Create Temporary Grid
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
REDIM CWord%%(16, 16)
RANDOMIZE (TIMER)
FOR N%% = 0 TO 16 STEP 16
FOR M%% = 0 TO 16
CWord%%(N%%, M%%) = True
NEXT M%%
NEXT N%%
FOR N%% = 0 TO 16
FOR M%% = 0 TO 16 STEP 16
CWord%%(N%%, M%%) = True
NEXT M%%
NEXT N%%
FOR N%% = 1 TO 15 STEP 2
FOR M%% = 1 TO 15 STEP 2
CWord%%(N%%, M%%) = True
NEXT M%%
NEXT N%%
FOR N%% = 2 TO 6 STEP 2
IF N%% = 6 THEN
L%% = 5 + INT(3 * RND)
ELSE
IF RND < 0.5 THEN
L%% = 5
ELSE
L%% = 7
END IF
END IF
CWord%%(N%%, L%%) = True
CWord%%(16 - N%%, 16 - L%%) = True
NEXT N%%
IF RND < 0.5 THEN
CWord%%(8, 8) = True
ELSE
CWord%%(8, 5) = True
CWord%%(8, 11) = True
END IF
'Place Additional Blanks
FOR M%% = 2 TO 6 STEP 2
'First check if line is already split
BreakExists%% = False
N%% = 1
WHILE NOT BreakExists%% AND N%% <= 8
IF CWord%%(N%%, M%%) THEN
BreakExists%% = True
ELSE
N%% = N%% + 1
END IF
WEND
IF NOT BreakExists%% THEN
L%% = 5 + 2 * INT(4 * RND)
CWord%%(L%%, M%%) = True
CWord%%(16 - L%%, 16 - M%%) = True
END IF
NEXT M%%
BreakExists%% = False
N%% = 1
WHILE NOT BreakExists%% AND N%% <= 8
IF CWord%%(N%%, 8) THEN
BreakExists%% = True
ELSE
N%% = N%% + 1
END IF
WEND
IF NOT BreakExists%% THEN
IF RND < 0.5 THEN
CWord%%(5, 8) = True
CWord%%(11, 8) = True
ELSE
CWord%%(7, 8) = True
CWord%%(9, 8) = True
END IF
END IF
'Check for Contiguousness
Sweeping%% = True
CWord%%(2, 1) = 1
WHILE Sweeping%%
Sweeping%% = False
FOR N%% = 2 TO 14 STEP 2
FOR M%% = 2 TO 14 STEP 2
IF CWord%%(N%%, M%%) = 0 AND (CWord%%(N%% - 1, M%%) = 1 OR CWord%%(N%% + 1, M%%) = 1 OR CWord%%(N%%, M%% - 1) = 1 OR CWord%%(N%%, M%% + 1) = 1) THEN
Sweeping%% = True
CWord%%(N%%, M%%) = 1
IF CWord%%(N%% - 1, M%%) = 0 THEN CWord%%(N%% - 1, M%%) = 1
IF CWord%%(N%% + 1, M%%) = 0 THEN CWord%%(N%% + 1, M%%) = 1
IF CWord%%(N%%, M%% - 1) = 0 THEN CWord%%(N%%, M%% - 1) = 1
IF CWord%%(N%%, M%% + 1) = 0 THEN CWord%%(N%%, M%% + 1) = 1
END IF
NEXT M%%
NEXT N%%
WEND
Contiguous%% = True
M%% = 2
N%% = 2
WHILE Contiguous%% AND N%% <= 14 AND M%% <= 14
IF CWord%%(N%%, M%%) = 0 THEN Contiguous%% = False
N%% = N%% + 2
IF N%% > 14 THEN
N%% = 2
M%% = M%% + 2
END IF
WEND
'Copy Grid (if contiguous)
IF Contiguous%% THEN
REDIM XWord%%(16, 16), TWords%%(10, 1), TotNos%%(10), AcrossDown%%(1, 10, 24, 1)
NoWords%% = 0
IF RND < 0.5 THEN
FOR N%% = 0 TO 16
FOR M%% = 0 TO 16
IF CWord%%(N%%, M%%) = 1 THEN
XWord%%(N%%, M%%) = False
ELSE
XWord%%(N%%, M%%) = True
END IF
NEXT M%%
NEXT N%%
ELSE
FOR N%% = 0 TO 16
FOR M%% = 0 TO 16
IF CWord%%(16 - N%%, M%%) = 1 THEN
XWord%%(N%%, M%%) = False
ELSE
XWord%%(N%%, M%%) = True
END IF
NEXT M%%
NEXT N%%
END IF
FOR N%% = 0 TO 15
LINE (10, N%% * 52 + 10)-(790, N%% * 52 + 10)
LINE (N%% * 52 + 10, 10)-(N%% * 52 + 10, 790)
NEXT N%%
FOR N%% = 1 TO 15
FOR M%% = 1 TO 15
IF XWord%%(N%%, M%%) THEN LINE ((N%% - 1) * 52 + 10, (M%% - 1) * 52 + 10)-(N%% * 52 + 10, M%% * 52 + 10), , BF
NEXT M%%
NEXT N%%
'Find the positions where the words can be placed and how they are classified
FOR N%% = 1 TO 14
FOR M%% = 1 TO 14
'Across & Down
FOR D%% = 0 TO 1
IF NOT XWord%%(N%%, M%%) AND NOT XWord%%(N%% + Orient%%(D%%, 0), M%% + Orient%%(D%%, 1)) AND XWord%%(N%% - Orient%%(D%%, 0), M%% - Orient%%(D%%, 1)) THEN
WordEnd%% = False
K%% = 4
WHILE NOT WordEnd%%
IF XWord%%(N%% + K%% * Orient%%(D%%, 0), M%% + K%% * Orient%%(D%%, 1)) THEN
WordEnd%% = True
ELSE
K%% = K%% + 1
END IF
WEND
TWords%%(K%%, D%%) = TWords%%(K%%, D%%) + 1
AcrossDown%%(D%%, K%%, TWords%%(K%%, D%%), 0) = N%%
AcrossDown%%(D%%, K%%, TWords%%(K%%, D%%), 1) = M%%
NoWords%% = NoWords%% + 1
END IF
NEXT D%%
NEXT M%%
NEXT N%%
FOR K%% = 4 TO 10
TotNos%%(K%%) = TWords%%(K%%, 0) + TWords%%(K%%, 1)
NEXT K%%
'Place Words in Grid Until No Cross-matches
N%% = 1
M%% = 1
CanFill%% = True
WordCount%% = 0
REDIM GridWords$(NoWords%%)
WHILE WordCount%% < NoWords%% AND CanFill%%
FOR Index%% = 0 TO 6 'Cackhanded way to check if word starts here
WHILE TotNos%%(FillOrder%%(Index%%)) > 0 AND CanFill%%
FOR D%% = 0 TO 1
IF TWords%%(FillOrder%%(Index%%), D%%) > 0 THEN 'Across&Down
FOR L%% = TWords%%(FillOrder%%(Index%%), D%%) TO 1 STEP -1
IF AcrossDown%%(D%%, FillOrder%%(Index%%), L%%, 0) = N%% AND AcrossDown%%(D%%, FillOrder%%(Index%%), L%%, 1) = M%% THEN
Crossed%% = False
EWord$ = ""
FOR P%% = 0 TO FillOrder%%(Index%%) - 1
IF XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)) > 0 THEN
Crossed%% = True
EWord$ = EWord$ + CHR$(XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)))
ELSE
EWord$ = EWord$ + "*"
END IF
NEXT P%%
IF INSTR(EWord$, "*") > 0 THEN
'Insert Word if possible
NoTries& = 0
CanFill%% = False
WHILE NoTries& < MaxTries& AND NOT CanFill%%
GoodMidEnd%% = False
WHILE NOT GoodMidEnd%%
'Check Middle&End Cross Letters
GoodMidEnd%% = True
Wordy$ = Alphabet$(FillOrder%%(Index%%) - 4, 1 + INT(RND * RndCount&(FillOrder%%(Index%%) - 4)))
P%% = 0
WHILE P%% <= FillOrder%%(Index%%) - 1 AND GoodMidEnd%%
IF XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)) = 0 AND XWord%%(N%% + P%% * Orient%%(D%%, 0) - 1 * Orient%%(D%%, 1), M%% + P%% * Orient%%(D%%, 1) - 1 * Orient%%(D%%, 0)) >= 0 AND XWord%%(N%% + P%% * Orient%%(D%%, 0) + 1 * Orient%%(D%%, 1), M%% + P%% * Orient%%(D%%, 1) + 1 * Orient%%(D%%, 0)) >= 0 AND INSTR(NonMid$, MID$(Wordy$, P%% + 1, 1)) > 0 THEN GoodMidEnd%% = False
IF XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)) = 0 AND XWord%%(N%% + P%% * Orient%%(D%%, 0) - 1 * Orient%%(D%%, 1), M%% + P%% * Orient%%(D%%, 1) - 1 * Orient%%(D%%, 0)) >= 0 AND XWord%%(N%% + P%% * Orient%%(D%%, 0) + 1 * Orient%%(D%%, 1), M%% + P%% * Orient%%(D%%, 1) + 1 * Orient%%(D%%, 0)) = -1 AND INSTR(NonEnd$, MID$(Wordy$, P%% + 1, 1)) > 0 THEN GoodMidEnd%% = False
P%% = P%% + 1
WEND
'Check if word exists in grid already
IF WordCount%% > 0 AND GoodMidEnd%% THEN
P%% = 1
WHILE P%% <= WordCount%% AND GoodMidEnd%%
IF Wordy$ = GridWords$(P%%) THEN GoodMidEnd%% = False
P%% = P%% + 1
WEND
END IF
WEND
'Check the new word fits existing crossing words
CanFill%% = True
P%% = 1
WHILE CanFill%% AND P%% <= FillOrder%%(Index%%)
IF MID$(EWord$, P%%, 1) <> "*" AND MID$(EWord$, P%%, 1) <> MID$(Wordy$, P%%, 1) THEN
CanFill%% = False
ELSE
P%% = P%% + 1
END IF
WEND
IF CanFill%% THEN
FOR P%% = 0 TO FillOrder%%(Index%%) - 1
Char% = ASC(MID$(Wordy$, P%% + 1, 1))
XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)) = Char%
_PUTIMAGE ((N%% + P%% * Orient%%(D%%, 0) - 1) * 52 + 22, (M%% + P%% * Orient%%(D%%, 1) - 1) * 52 + 22), LesLettres&(Char% - 64)
NEXT P%%
WordCount%% = WordCount%% + 1
GridWords$(WordCount%%) = Wordy$
TotNos%%(FillOrder%%(Index%%)) = TotNos%%(FillOrder%%(Index%%)) - 1
ELSE
NoTries& = NoTries& + 1
END IF
WEND
IF SloMo%% THEN
IF NOT CanFill%% THEN
FOR P%% = 0 TO FillOrder%%(Index%%) - 1
IF MID$(EWord$, P%% + 1, 1) = "*" THEN _PUTIMAGE ((N%% + P%% * Orient%%(D%%, 0) - 1) * 52 + 22, (M%% + P%% * Orient%%(D%%, 1) - 1) * 52 + 22), LesLettres&(0)
NEXT P%%
END IF
_DELAY 1.5
END IF
END IF
END IF
IF NOT CanFill%% THEN EXIT FOR
NEXT L%%
END IF
IF NOT CanFill%% THEN EXIT FOR
NEXT D%%
M%% = M%% + 1
IF M%% > 14 THEN
N%% = N%% + 1
M%% = 1
IF N%% > 14 THEN N%% = 1
END IF
WEND
IF NOT CanFill%% THEN EXIT FOR
NEXT Index%%
WEND
'Use up stray keypresses, display completed grid and/or wait for keypress
WHILE INKEY$ <> ""
WEND
IF CanFill%% THEN
'Completed grid displayed
k$ = ""
WHILE k$ = ""
k$ = INKEY$
_LIMIT 30
WEND
IF k$ <> "" THEN
IF ASC(k$) = 27 THEN
DoXWord%% = False
ELSEIF LCASE$(k$) = "f" THEN
IF SloMo%% THEN
SloMo%% = False
ELSE
SloMo%% = True
END IF
END IF
END IF
ELSEIF SloMo%% THEN
'Show Partial Grid
k$ = ""
WHILE k$ = ""
_LIMIT 30
k$ = INKEY$
IF k$ <> "" THEN
IF ASC(k$) = 27 THEN
DoXWord%% = False
ELSEIF LCASE$(k$) = "f" THEN
SloMo%% = False
END IF
END IF
WEND
END IF
END IF
WEND
FOR N%% = 0 TO 26
_FREEIMAGE LesLettres&(N%%)
NEXT N%%
SYSTEM
OrientFill:
DATA 1,0,0,1
DATA 10,9,8,7,6,4,5
CharOffset:
DATA 2,2,2,2,2,2,2,2,8,6,2,2,0,4,2,2,2,2,4,2,2,2,0,2,2,2Crossword Maker
Code: (Select All)
'Crossword Maker by Magdha 2026-01-12
'Output from this program used with Draw Completed Grid.bas
'The order of events is sometimes peculiar (from the functionality of Inform?), in partcular __UI_TextChanged routine.
'For example, loading from file can call the contiguity routine 225 times when expected only on the last loaded item.
'It is not noticeable (on a Corei5 processor), but remains an oddity.
'Even with code written to avoid __UI_TextChanged, it will happen anyway.
': This program uses
': InForm-PE for QB64-PE - v1.5.8 based upon InForm by Fellippe Heitor
': Copyright (c) 2025 QB64 Phoenix Edition Team
': https://github.com/QB64-Phoenix-Edition/InForm-PE
'-----------------------------------------------------------
': Controls' IDs: ------------------------------------------------------------------
'Load Control IDs from DIM-SHARED-Lines.bas
'Program Variables:
DIM SHARED GoodGrid%%, GridPosn%, CanEnter%%, CheckGrid%%, GridValue%(225), GridArr%(500, 1) 'Assumption that there are never 500 objects
': External modules: ---------------------------------------------------------------
'$INCLUDE:'DIM-SHARED-Lines.bas'
'$INCLUDE:'InForm\InForm.bi'
'$INCLUDE:'InForm\xp.uitheme'
'$INCLUDE:'Crossword Maker.frm'
'$INCLUDE:'Set-GridArray-Sub.bas'
': Event procedures: ---------------------------------------------------------------
SUB __UI_BeforeInit
GoodGrid%% = False
GridPosn% = 1
CanEnter%% = True
'The CanEnter variable is coded to keep __UI_TextChanged from occuring when not desired
'In fact the __UI_TextChanged always happens anyway after CanEnter is returned to True
'It is entirely useless but is left in the code as to what is supposed to happen (but doesn't)
CheckGrid%% = True
END SUB
SUB __UI_OnLoad
_SCREENMOVE 100, 5
CALL SetGridArr
Caption(EvensRB) = "New"
Caption(EvenOddRB) = "Load"
Caption(LayoutFR) = "New/Load"
Caption(NotesLB) = "New Grid or Load from File"
SetRadioButtonValue EvensRB
Control(OddEvenRB).Hidden = True
Control(OddsRB).Hidden = True
Control(SaveBT).Disabled = True
SetFocus NewLoadBT
END SUB
SUB __UI_BeforeUpdateDisplay
'This event occurs at approximately 60 frames per second.
'You can change the update frequency by calling SetFrameRate DesiredRate%
SetFrameRate 30
END SUB
SUB __UI_Click (id AS INTEGER)
STATIC NotFirstTime%%, LoadGrid%%, Decide%%
IF NOT NotFirstTime%% THEN
NotFirstTime%% = True
Decide%% = True
LoadGrid%% = False
END IF
SELECT CASE id
CASE ExitBT
SYSTEM
CASE NewLoadBT
IF Decide%% THEN
CheckGrid%% = False
Decide%% = False
CanEnter%% = False
'Prevent Manual Input when loading
FOR A% = 1 TO 225
GridValue%(A%) = 0
Text(GridArr%(A%, 1)) = ""
Control(GridArr%(A%, 1)).Disabled = True
NEXT A%
'Choose Either:
'New (set evens/evenodd/oddeven/odds blocked squares)
'Or Load from File
IF Control(EvensRB).Value THEN
'Goto Set New Grid Type
Control(OddEvenRB).Hidden = False
Control(OddsRB).Hidden = False
Caption(EvensRB) = "Even-Even"
Caption(EvenOddRB) = "Even-Odd"
Caption(LayoutFR) = "Layout"
Caption(NewLoadBT) = "Layout"
Caption(NotesLB) = "Choose Grid Layout"
ELSE
'Load from grid.txt
OPEN "grid.txt" FOR INPUT AS #1
LINE INPUT #1, FirstLine$
IF FirstLine$ = STRING$(44, "*") THEN
'Ignore 1st line
FOR A% = 1 TO 225
INPUT #1, GridValue%(A%)
NEXT A%
ELSE
M%% = 1
WHILE LEN(FirstLine$) > 3
GridValue%(M%%) = VAL(LEFT$(FirstLine$, 2))
FirstLine$ = RIGHT$(FirstLine$, LEN(FirstLine$) - 3)
M%% = M%% + 1
WEND
GridValue%(15) = VAL(FirstLine$)
FOR A% = 16 TO 225
INPUT #1, GridValue%(A%)
NEXT A%
END IF
CLOSE #1
LoadGrid%% = True
END IF
ELSE
'New grid
IsEmpty%% = True
IF Control(EvensRB).Value THEN
'Even-Even Grid
FOR A% = 1 TO 225
IF A% MOD 30 = 17 AND IsEmpty%% THEN
IsEmpty%% = False
GridValue%(A%) = 42
ELSEIF NOT IsEmpty%% THEN
IF A% \ 2 = A% / 2 THEN
GridValue%(A%) = 0
ELSE
GridValue%(A%) = 42
END IF
IF A% MOD 30 = 29 THEN IsEmpty%% = True
ELSE
GridValue%(A%) = 0
END IF
NEXT A%
ELSEIF Control(EvenOddRB).Value THEN
'Even-Odd grid
FOR A% = 1 TO 225
IF A% MOD 30 = 16 AND IsEmpty%% THEN
IsEmpty%% = False
GridValue%(A%) = 42
ELSEIF NOT IsEmpty%% THEN
IF A% \ 2 = A% / 2 THEN
GridValue%(A%) = 42
ELSE
GridValue%(A%) = 0
END IF
IF A% MOD 30 = 0 THEN IsEmpty%% = True
ELSE
GridValue%(A%) = 0
END IF
NEXT A%
ELSEIF Control(OddEvenRB).Value THEN
'Odd-Even Grid
FOR A% = 1 TO 225
IF A% MOD 30 = 2 AND IsEmpty%% THEN
IsEmpty%% = False
GridValue%(A%) = 42
ELSEIF NOT IsEmpty%% THEN
IF A% \ 2 = A% / 2 THEN
GridValue%(A%) = 42
ELSE
GridValue%(A%) = 0
END IF
IF A% MOD 30 = 14 THEN IsEmpty%% = True
ELSE
GridValue%(A%) = 0
END IF
NEXT A%
ELSE
'Odds Grid
FOR A% = 1 TO 225
IF A% MOD 30 = 1 AND IsEmpty%% THEN
IsEmpty%% = False
GridValue%(A%) = 42
ELSEIF NOT IsEmpty%% THEN
IF A% \ 2 = A% / 2 THEN
GridValue%(A%) = 0
ELSE
GridValue%(A%) = 42
END IF
IF A% MOD 30 = 15 THEN IsEmpty%% = True
ELSE
GridValue%(A%) = 0
END IF
NEXT A%
END IF
LoadGrid%% = True
END IF
IF LoadGrid%% THEN
FOR A% = 1 TO 225
IF GridValue%(A%) = 0 THEN
Text(GridArr%(A%, 1)) = ""
ELSE
Text(GridArr%(A%, 1)) = CHR$(GridValue%(A%))
END IF
NEXT A%
Blocked%% = True
GridPosn% = 1
WHILE Blocked%%
'__UI_TextChanged seems to supercede this, even if code written to avoid this action
IF GridValue%(GridPosn%) <> 42 THEN
Blocked%% = False
ELSE
GridPosn% = GridPosn% + 1
END IF
WEND
SetFocus GridArr%(GridPosn%, 1)
Caption(NotesLB) = "Grid Incomplete"
Caption(EvensRB) = "New"
Caption(EvenOddRB) = "Load"
Caption(LayoutFR) = "New/Load"
Caption(NotesLB) = "New Grid or Load from File"
Caption(NewLoadBT) = "New/Load"
SetRadioButtonValue EvensRB
Control(OddEvenRB).Hidden = True
Control(OddsRB).Hidden = True
Control(SaveBT).Disabled = True
Decide%% = True
LoadGrid%% = False
CheckGrid%% = True
CanEnter%% = True
CALL GridCheck
END IF
CASE SaveBT
OPEN "gridtext.txt" FOR OUTPUT AS #2
IF NOT GoodGrid%% THEN 'Criterion for GoodGrid is perfect completed grid (ready for printing)
PRINT #2, STRING$(44, "*")
END IF
FOR A% = 1 TO 225
IF A% MOD 15 > 0 THEN
PRINT #2, LTRIM$(CHR$(GridValue%(A%))); ",";
ELSE
PRINT #2, LTRIM$(CHR$(GridValue%(A%)))
END IF
NEXT A%
CLOSE #2
Control(SaveBT).Disabled = True
END SELECT
END SUB
SUB __UI_KeyPress (id AS INTEGER)
IF id >= GridTB1 AND id <= GridTB225 THEN
'Use arrow keys to move cell.
'NB If complete line of asterisks, this routine will not exit loop
GridPosn% = GridArr%(id, 0)
SELECT CASE __UI_KeyHit
CASE 18432 'Up
SafeSpot%% = False
WHILE NOT SafeSpot%%
IF (GridPosn% - 1) \ 15 = 0 THEN
GridPosn% = GridPosn% + 210
ELSE
GridPosn% = GridPosn% - 15
END IF
IF GridPosn% <= 113 OR GridValue%(GridPosn%) <> 42 THEN SafeSpot%% = True
WEND
SetFocus GridArr%(GridPosn%, 1)
CASE 19200 'Left
SafeSpot%% = False
WHILE NOT SafeSpot%%
IF GridPosn% MOD 15 = 1 THEN
GridPosn% = GridPosn% + 14
ELSE
GridPosn% = GridPosn% - 1
END IF
IF GridPosn% <= 113 OR GridValue%(GridPosn%) <> 42 THEN SafeSpot%% = True
WEND
SetFocus GridArr%(GridPosn%, 1)
CASE 20480 'Down
SafeSpot%% = False
WHILE NOT SafeSpot%%
IF (GridPosn% - 1) \ 15 = 14 THEN
GridPosn% = GridPosn% - 210
ELSE
GridPosn% = GridPosn% + 15
IF GridPosn% <= 113 OR GridValue%(GridPosn%) <> 42 THEN SafeSpot%% = True
END IF
WEND
SetFocus GridArr%(GridPosn%, 1)
CASE 19712 'Right
SafeSpot%% = False
WHILE NOT SafeSpot%%
IF GridPosn% MOD 15 = 0 THEN
GridPosn% = GridPosn% - 14
ELSE
GridPosn% = GridPosn% + 1
END IF
IF GridPosn% <= 113 OR GridValue%(GridPosn%) <> 42 THEN SafeSpot%% = True
WEND
SetFocus GridArr%(GridPosn%, 1)
CASE 18176 'Home
GridPosn% = 1
SetFocus GridArr%(GridPosn%, 1)
CASE 20224 'End
GridPosn% = 225
SafeSpot%% = False
WHILE NOT SafeSpot%%
IF GridValue%(GridPosn%) <> 42 THEN
SafeSpot%% = True
ELSE
GridPosn% = GridPosn% - 1
END IF
WEND
SetFocus GridArr%(GridPosn%, 1)
END SELECT
END IF
END SUB
SUB __UI_TextChanged (id AS INTEGER)
STATIC NotFirstTime%%, WasIllegal%%
IF NOT NotFirstTime%% THEN
NotFirstTime%% = True
WasIllegal%% = False
END IF
IF (id >= GridTB1 AND id <= GridTB225) AND CanEnter%% THEN
'This routine does appear to work for all circumstances
'Routine to place text in grid
'This part of the routine happens even if CanEnter is temporarily set to False
GridPosn% = GridArr%(id, 0) 'Value goes from 1 to 225
IF WasIllegal%% THEN
WasIllegal%% = False
ELSEIF Text(id) = "" THEN
IF GridValue%(GridPosn%) = 42 THEN 'Was asterisk
CALL SetText("", 226 - GridPosn%)
END IF
GridValue%(GridPosn%) = 0
ELSEIF LEN(Text(id)) > 1 THEN
CALL SetText("", GridPosn%)
ELSEIF (Text(id) >= "A" AND Text(id) <= "Z") OR (Text(id) >= "a" AND Text(id) <= "z") THEN
CALL SetText(UCASE$(Text(id)), GridPosn%)
IF GridValue%(226 - GridPosn%) = 42 THEN 'Was asterisk
CALL SetText("", 226 - GridPosn%)
END IF
CALL IndexCell
ELSEIF Text(id) = "*" OR Text(id) = " " OR Text(id) = "8" THEN
IF GridPosn% <= 113 THEN
CALL SetText("*", GridPosn%)
IF GridPosn% < 113 THEN 'Make partner cell asterisk
CALL SetText("*", 226 - GridPosn%)
END IF
CALL IndexCell
ELSEIF NOT Control(GridArr%(GridPosn%, 1)).Disabled THEN
'Don't allow asterisk if input at available square beyond 113
'Cells already containing asterisk are already
SOUND 1318, 1
CALL SetText("", GridPosn%)
END IF
ELSE 'Any Illegal Character
SOUND 1046, 2
WasIllegal%% = True
CALL SetText("", GridPosn%)
END IF
IF CheckGrid%% THEN CALL GridCheck
END IF
END SUB
SUB __UI_MouseEnter (id AS LONG)
END SUB
SUB __UI_MouseLeave (id AS LONG)
END SUB
SUB __UI_FocusIn (id AS LONG)
END SUB
SUB __UI_FocusOut (id AS LONG)
END SUB
SUB __UI_MouseDown (id AS LONG)
END SUB
SUB __UI_MouseUp (id AS LONG)
END SUB
SUB __UI_ValueChanged (id AS LONG)
END SUB
SUB __UI_FormResized
END SUB
SUB __UI_BeforeUnload
'If you set __UI_UnloadSignal = False here you can
'cancel the user's request to close.
END SUB
SUB IndexCell
GridPosn% = GridPosn% + 1
IF GridPosn% > 225 THEN GridPosn% = 1
SetFocus GridArr%(GridPosn%, 1)
END SUB
SUB SetText (T$, Posn%)
CanEnter%% = False
Text(GridArr%(Posn%, 1)) = T$
IF T$ = "" THEN
GridValue%(Posn%) = 0
ELSE
GridValue%(Posn%) = ASC(T$)
END IF
CanEnter%% = True
END SUB
SUB GridCheck
'Check the grid and change Label Text As Appropriate at Each Stage
'This routine was part of __UI_TextChanged where it worked but caused oddities with Load from File (but still worked)
'With this routine placed here, Variable CheckGrid is required
'The program (because this routine is placed here?) is sensitive when inputting asterisks:
'A non-clean keypress can cause an illegal entry and the partner asterisk is missing - don't input too fast
FOR A% = 1 TO 225
IF A% > 113 AND GridValue%(A%) = 42 THEN
Control(GridArr%(A%, 1)).Disabled = True
ELSE
Control(GridArr%(A%, 1)).Disabled = False
END IF
NEXT A%
'1. Check for Empty Grid
A% = 1
GoodGrid%% = False
WHILE A% <= 225 AND NOT GoodGrid%%
IF GridValue%(A%) > 0 THEN
GoodGrid%% = True
ELSE
A% = A% + 1
END IF
WEND
IF NOT GoodGrid%% THEN
'Grid Empty
Control(SaveBT).Disabled = True
Caption(NotesLB) = "Grid Empty"
ELSE
'2. Grid Not Empty - Check for Completed Grid
Control(SaveBT).Disabled = False
A% = 1
WHILE A% <= 225 AND GoodGrid%%
IF GridValue%(A%) = 0 THEN
GoodGrid%% = False
ELSE
A% = A% + 1
END IF
WEND
IF NOT GoodGrid%% THEN
Caption(NotesLB) = "Grid Incomplete"
ELSE
'3. Grid Full - Check for Illegal Characters.
'NB Already dealt with at input: should not need Illegals check
A% = 1
WHILE A% <= 225 AND GoodGrid%%
IF GridValue%(A%) = 42 OR (GridValue%(A%) >= 65 AND GridValue%(A%) <= 90) THEN
A% = A% + 1
ELSE
GoodGrid%% = False
END IF
WEND
IF NOT GoodGrid%% THEN
'Illegal Character
Caption(NotesLB) = "Illegal Character"
ELSE
'4. (No Illegal Characters). Now look for Single and Double Letters
'Do all following checks in an array where squares with letters have starting value 0
REDIM CWord%%(16, 16)
FOR N%% = 0 TO 16
CWord%%(N%%, 16) = 42
CWord%%(N%%, 0) = 42
NEXT N%%
FOR M%% = 0 TO 16
CWord%%(16, M%%) = 42
CWord%%(0, M%%) = 42
NEXT M%%
FOR A% = 1 TO 225
N%% = ((A% - 1) \ 15) + 1
M%% = ((A% - 1) MOD 15) + 1
IF GridValue%(A%) = 42 THEN
CWord%%(N%%, M%%) = GridValue%(A%)
ELSE
CWord%%(N%%, M%%) = 0
END IF
NEXT A%
'Single Character:
N%% = 1
M%% = 1
WHILE N%% <= 15 AND GoodGrid%%
IF CWord%%(N%%, M%%) <> 42 AND CWord%%(N%% - 1, M%%) = 42 AND CWord%%(N%% + 1, M%%) = 42 AND CWord%%(N%%, M%% - 1) = 42 AND CWord%%(N%%, M%% + 1) = 42 THEN
GoodGrid%% = False
ELSE
M%% = M%% + 1
IF M%% > 15 THEN
M%% = 1
N%% = N%% + 1
END IF
END IF
WEND
'2-letter word
N%% = 1
M%% = 1
WHILE N%% <= 14 AND GoodGrid%% 'Cannot have +2 at 15
IF CWord%%(N%%, M%% - 1) = 42 AND CWord%%(N%%, M%%) <> 42 AND CWord%%(N%%, M%% + 1) <> 42 AND CWord%%(N%%, M%% + 2) = 42 THEN
'2-letter Across Word
GoodGrid%% = False
ELSEIF CWord%%(N%% - 1, M%%) = 42 AND CWord%%(N%%, M%%) <> 42 AND CWord%%(N%% + 1, M%%) <> 42 AND CWord%%(N%% + 2, M%%) = 42 THEN
'2-letter Down Word
GoodGrid%% = False
ELSE
M%% = M%% + 1
IF M%% > 14 THEN
M%% = 1
N%% = N%% + 1
END IF
END IF
WEND
IF NOT GoodGrid%% THEN
'Single or Double Letter
Caption(NotesLB) = "Single or Double Letter"
ELSE
'5. Check for completely blocked rows/columns
N%% = 1
WHILE N%% <= 15 AND GoodGrid%%
GoodGrid%% = False
M%% = 1
WHILE M%% <= 15 AND NOT GoodGrid%%
IF CWord%%(N%%, M%%) <> 42 THEN
GoodGrid%% = True
ELSE
M%% = M%% + 1
END IF
WEND
IF GoodGrid%% THEN N%% = N%% + 1
WEND
M%% = 1
WHILE M%% <= 15 AND GoodGrid%%
GoodGrid%% = False
N%% = 1
WHILE N%% <= 15 AND NOT GoodGrid%%
IF CWord%%(N%%, M%%) <> 42 THEN
GoodGrid%% = True
ELSE
N%% = N%% + 1
END IF
WEND
IF GoodGrid%% THEN M%% = M%% + 1
WEND
IF NOT GoodGrid%% THEN
Caption(NotesLB) = "Illegal Row/Column"
ELSE
'6. Check decent block/character ("hand-waving looks like a decent crossword grid)
'Count Row Odd Blocks
RowOddBlocks% = 0
FOR N%% = 1 TO 15 STEP 2 'Rows
FOR M%% = 1 TO 15 'STEP 2 'Cloumns
IF CWord%%(N%%, M%%) = 42 THEN RowOddBlocks% = RowOddBlocks% + 1
NEXT M%%
NEXT N%%
'Count Row Even Blocks
RowEvenBlocks% = 0
FOR N%% = 2 TO 14 STEP 2 'Rows
FOR M%% = 1 TO 15 'STEP 2 'Cloumns
IF CWord%%(N%%, M%%) = 42 THEN RowEvenBlocks% = RowEvenBlocks% + 1
NEXT M%%
NEXT N%%
'Count Column Odd Blocks
ColumnOddBlocks% = 0
FOR M%% = 1 TO 15 STEP 2 'Columns
FOR N%% = 1 TO 15 'Rows
IF CWord%%(N%%, M%%) = 42 THEN ColumnOddBlocks% = ColumnOddBlocks% + 1
NEXT N%%
NEXT M%%
'Count Column Even Blocks
ColumnEvenBlocks% = 0
FOR M%% = 2 TO 14 STEP 2 'Cloumns
FOR N%% = 1 TO 15 'STEP 2 'Rows
IF CWord%%(N%%, M%%) = 42 THEN ColumnEvenBlocks% = ColumnEvenBlocks% + 1
NEXT N%%
NEXT M%%
A1% = RowOddBlocks% + RowEvenBlocks%
A2% = RowOddBlocks% + ColumnOddBlocks%
A3% = RowOddBlocks% + ColumnEvenBlocks%
A4% = RowEvenBlocks% + ColumnOddBlocks%
A5% = RowEvenBlocks% + ColumnEvenBlocks%
A6% = ColumnOddBlocks% + ColumnEvenBlocks%
A7% = RowOddBlocks% + RowEvenBlocks% + ColumnOddBlocks% + ColumnEvenBlocks%
IF A7% < 120 OR (A1% < 56 AND A2% < 56 AND A3% < 56 AND A4% < 56 AND A5% < 56 AND A6% < 56) THEN
GoodGrid%% = False
Caption(NotesLB) = "Unshapely"
ELSE
'7. Check contiguity (this is the correct word!!)
'Routine to check contiguity adapted from Crossword Generator
'Find first unblocked square on first row - already checked for non-blocked square existence
FirstFound%% = False
M%% = 1
WHILE NOT FirstFound%%
IF CWord%%(1, M%%) = 0 THEN
FirstFound%% = True
CWord%%(1, M%%) = 1 'First seed cell
ELSE
M%% = M%% + 1
END IF
WEND
'Seed cells (=1) next to already seeded cells
Sweeping%% = True
WHILE Sweeping%%
Sweeping%% = False
FOR N%% = 1 TO 15
FOR M%% = 1 TO 15
IF CWord%%(N%%, M%%) = 1 AND (CWord%%(N%% - 1, M%%) = 0 OR CWord%%(N%% + 1, M%%) = 0 OR CWord%%(N%%, M%% - 1) = 0 OR CWord%%(N%%, M%% + 1) = 0) THEN
Sweeping%% = True
IF CWord%%(N%% - 1, M%%) = 0 THEN CWord%%(N%% - 1, M%%) = 1
IF CWord%%(N%% + 1, M%%) = 0 THEN CWord%%(N%% + 1, M%%) = 1
IF CWord%%(N%%, M%% - 1) = 0 THEN CWord%%(N%%, M%% - 1) = 1
IF CWord%%(N%%, M%% + 1) = 0 THEN CWord%%(N%%, M%% + 1) = 1
END IF
NEXT M%%
NEXT N%%
WEND
'Look for any unseeded cells which cannot be seeded
M%% = 1
N%% = 1
WHILE GoodGrid%% AND N%% <= 15
IF CWord%%(N%%, M%%) = 0 THEN
GoodGrid%% = False
ELSE
M%% = M%% + 1
IF M%% > 15 THEN
M%% = 1
N%% = N%% + 1
END IF
END IF
WEND
IF NOT GoodGrid%% THEN
Caption(NotesLB) = "Grid Not Contiguous"
ELSE
'8. Ta-Da!
'We have a proper contiguous filled grid ready for DrawGrid1/2
Caption(NotesLB) = "Grid Complete"
END IF
END IF
END IF
END IF
END IF
END IF
END IF
END SUB
'This $INCLUDE always comes last, otherwise READ conflict in Inform.ui:
'$INCLUDE:'InForm\InForm.ui'Cipher Crossword Generator
Code: (Select All)
'Cipher Crossword Generator (every letter of the alhpabet used) by Magdha 2026-01-11
'13x13 Grids, 26 words of lengths 3 to 8
CONST False = 0, True = NOT False
CONST Spex$ = "zqjxkvbp", BadEnd$ = "qjvzbufxwipo" 'Uncommon letters to be placed first and avoided at word ends
RANDOMIZE (TIMER)
SpexLen%% = LEN(Spex$)
DIM SpexOrd%%(SpexLen%%)
FOR K%% = 1 TO SpexLen%%
SpexOrd%%(K%%) = K%%
NEXT K%%
'Load Dictionary
REDIM BLens&(8), Beta$(6000, 8), AlreadyUsed$(26), SpexBet$(1000, 8, SpexLen%%), SpexLens&(8, SpexLen%%)
OPEN "CommonWords.txt" FOR INPUT AS #1
PRINT "Loading Files .";
WHILE NOT EOF(1)
INPUT #1, T$
L%% = LEN(T$)
BLens&(L%%) = BLens&(L%%) + 1
Beta$(BLens&(L%%), L%%) = T$
'Have to load SpexBet$ data
FOR K%% = 1 TO SpexLen%%
S$ = MID$(Spex$, K%%, 1)
IF INSTR(T$, S$) <> 0 THEN
SpexLens&(L%%, K%%) = SpexLens&(L%%, K%%) + 1
SpexBet$(SpexLens&(L%%, K%%), L%%, K%%) = T$
END IF
NEXT K%%
IF TIMER > Start! + 1 THEN
PRINT ".";
Start! = TIMER
END IF
WEND
CLOSE #1
'Load Grids
PRINT "Loading Grids"
DIM Grid%%(14, 14), Words%%(26, 4) ', OutputGrid$(14)
WordCount%% = 0
FOR N%% = 0 TO 14
Grid%%(N%%, 14) = True
Grid%%(N%%, 0) = True
Grid%%(0, N%%) = True
Grid%%(14, N%%) = True
NEXT N%%
OPEN "grids.txt" FOR INPUT AS #1
GridNo%% = 0
WHILE NOT EOF(1)
GridNo%% = GridNo%% + 1
FOR M%% = 0 TO 7
LINE INPUT #1, T$
NEXT M%%
WEND
CLOSE #1
O%% = 0
GridNo%% = 1 + INT(RND * GridNo%%)
'One of 32 grids used
OPEN "grids.txt" FOR INPUT AS #1
WHILE O%% <> GridNo%%
O%% = O%% + 1
FOR M%% = 0 TO 7
LINE INPUT #1, T$
IF M%% >= 1 AND O%% = GridNo%% THEN
MoreBlanks%% = True
WHILE MoreBlanks%%
Comma%% = INSTR(T$, ",")
IF Comma%% = 0 THEN
MoreBlanks%% = False
Posn%% = VAL(T$)
ELSE
Posn%% = VAL(LEFT$((T$), Comma%% - 1))
T$ = RIGHT$(T$, LEN(T$) - Comma%%)
END IF
Grid%%(Posn%%, M%%) = True
Grid%%(14 - Posn%%, 14 - M%%) = True
WEND
END IF
NEXT M%%
WEND
CLOSE #1
'Now find the Across and Down word positions
FOR J%% = 1 TO 13
FOR I%% = 1 TO 13
IF Grid%%(I%% - 1, J%%) AND NOT Grid%%(I%%, J%%) AND NOT Grid%%(I%% + 1, J%%) THEN
'Across Word
WordCount%% = WordCount%% + 1
Words%%(WordCount%%, 1) = True
Words%%(WordCount%%, 3) = I%%
Words%%(WordCount%%, 2) = J%%
MoreLetters%% = True
L~%% = 3
WHILE MoreLetters%% = True
IF Grid%%(I%% + L~%%, J%%) THEN
Words%%(WordCount%%, 4) = L~%%
MoreLetters%% = False
ELSE
L~%% = L~%% + 1
END IF
WEND
END IF
IF Grid%%(I%%, J%% - 1) AND NOT Grid%%(I%%, J%%) AND NOT Grid%%(I%%, J%% + 1) THEN
'Down Word
WordCount%% = WordCount%% + 1
Words%%(WordCount%%, 1) = False
Words%%(WordCount%%, 3) = I%%
Words%%(WordCount%%, 2) = J%%
MoreLetters%% = True
L~%% = 3
WHILE MoreLetters%% = True
IF Grid%%(I%%, J%% + L~%%) THEN
Words%%(WordCount%%, 4) = L~%%
MoreLetters%% = False
ELSE
L~%% = L~%% + 1
END IF
WEND
END IF
NEXT I%%
NEXT J%%
'Now sort the words longest to shortest
Jump%% = 32
WHILE Jump%% > 1
Jump%% = (Jump%% - 1) \ 2
Finished%% = False
WHILE NOT Finished%%
Finished%% = True
FOR Upper%% = 1 TO 26 - Jump%%
Lower%% = Upper%% + Jump%%
IF Words%%(Upper%%, 4) < Words%%(Lower%%, 4) THEN
FOR N%% = 0 TO 4
SWAP Words%%(Upper%%, N%%), Words%%(Lower%%, N%%)
NEXT N%%
Finished%% = False
END IF
NEXT Upper%%
WEND
WEND
'And now swap length 3 with length 4 (3-letter words less common)
Jump%% = 32
WHILE Jump%% > 1
Jump%% = (Jump%% - 1) \ 2
Finished%% = False
WHILE NOT Finished%%
Finished%% = True
FOR Upper%% = 1 TO 26 - Jump%%
Lower%% = Upper%% + Jump%%
IF Words%%(Upper%%, 4) > Words%%(Lower%%, 4) AND Words%%(Upper%%, 4) = 4 AND Words%%(Lower%%, 4) = 3 THEN
FOR N%% = 0 TO 4
SWAP Words%%(Upper%%, N%%), Words%%(Lower%%, N%%)
NEXT N%%
Finished%% = False
END IF
NEXT Upper%%
WEND
WEND
PRINT "Grid Number"; GridNo%%
'Fill the grid
TriesCount~& = 0
AtStart! = TIMER
PRINT "Filling Grid:"
WordNo%% = 1
WHILE WordNo%% <= 26
IF WordNo%% = 1 THEN
TriesCount~& = TriesCount~& + 1 'Trial program shows that a solution can be found in the range 1 (~ i in 350) to ~40000 tries (grids 10, 12, 17, 18, 19 take many more tries than other grids)
N1%% = 1
W4%% = Words%%(WordNo%%, 4) 'Word Length
W3%% = Words%%(WordNo%%, 3) 'I Dimension
W2%% = Words%%(WordNo%%, 2) 'J Dimension
W1%% = Words%%(WordNo%%, 1) 'Across/Down
FOR M%% = 1 TO 8
R1%% = 1 + INT(SpexLen%% * RND)
IsSame%% = True
WHILE IsSame%%
R2%% = 1 + INT(SpexLen%% * RND)
IF R2%% <> R1%% THEN IsSame%% = False
WEND
SWAP SpexOrd%%(R1%%), SpexOrd%%(R2%%)
NEXT M%%
FOR I%% = 1 TO 13
FOR J%% = 1 TO 13
IF Grid%%(I%%, J%%) > 0 THEN Grid%%(I%%, J%%) = 0 'Remove any previously added letters
NEXT J%%
NEXT I%%
FOR K%% = 1 TO 26
Words%%(K%%, 0) = False 'Marker for all letters present
NEXT K%%
END IF
'Find a word that fits
CommonChoix% = 0
DoesFit%% = False
WHILE NOT DoesFit%%
'Find a word amongst current word length list
CommonChoix% = CommonChoix% + 1
IndexN1%% = False
IF N1%% <= SpexLen%% AND RND < 0.7 THEN
IndexN1%% = True
CommonWord$ = SpexBet$(1 + INT(SpexLens&(W4%%, SpexOrd%%(N1%%)) * RND), W4%%, SpexOrd%%(N1%%))
ELSE
CommonWord$ = Beta$(1 + INT(BLens&(W4%%) * RND), W4%%)
END IF
'Now find common words that fit
'Agree with existing letters
'Don't allow future difficult endings
'Don't allow future difficult crossings - not used: makes times worse
K%% = 1
DoesFit%% = True
WHILE K%% <= W4%% AND DoesFit%%
IF W1%% THEN
'Across
IF Grid%%(W3%% + K%% - 1, W2%%) >= 1 THEN
'Check if same as exisitng
IF Grid%%(W3%% + K%% - 1, W2%%) <> ASC(MID$(CommonWord$, K%%, 1)) - 96 THEN DoesFit%% = False
ELSEIF Grid%%(W3%% + K%% - 1, W2%% - 1) >= 0 AND Grid%%(W3%% + K%% - 1, W2%% + 1) = -1 THEN
'Check bad ending
IF INSTR(BadEnd$, MID$(CommonWord$, K%%, 1)) <> 0 THEN DoesFit%% = False
END IF
ELSE
'Down
IF Grid%%(W3%%, W2%% + K%% - 1) >= 1 THEN
'Check if same as exisitng
IF Grid%%(W3%%, W2%% + K%% - 1) <> ASC(MID$(CommonWord$, K%%, 1)) - 96 THEN DoesFit%% = False
ELSEIF Grid%%(W3%% - 1, W2%% + K%% - 1) >= 0 AND Grid%%(W3%% + 1, W2%% + K%% - 1) = -1 THEN
'Check bad ending
IF INSTR(BadEnd$, MID$(CommonWord$, K%%, 1)) <> 0 THEN DoesFit%% = False
END IF
END IF
K%% = K%% + 1
WEND
IF DoesFit%% THEN
'Check if word exists in grid
'Trial program shows that this happens quite often!
M%% = 1
WHILE WordNo%% >= 2 AND DoesFit%% AND M%% <= WordNo%% - 1
IF LEFT$(CommonWord$, 3) = LEFT$(AlreadyUsed$(M%%), 3) THEN DoesFit%% = False
M%% = M%% + 1
WEND
AlreadyUsed$(WordNo%%) = CommonWord$
END IF
IF DoesFit%% THEN
'Stop looking - found a word
'Add word to grid
IF W1%% THEN
'Across
FOR K%% = 1 TO W4%%
Grid%%(W3%% + K%% - 1, W2%%) = ASC(MID$(CommonWord$, K%%, 1)) - 96
NEXT K%%
ELSE
'Down
FOR K%% = 1 TO W4%%
Grid%%(W3%%, W2%% + K%% - 1) = ASC(MID$(CommonWord$, K%%, 1)) - 96
NEXT K%%
END IF
WordNo%% = WordNo%% + 1
IF WordNo%% <= 26 THEN
W4%% = Words%%(WordNo%%, 4)
W3%% = Words%%(WordNo%%, 3)
W2%% = Words%%(WordNo%%, 2)
W1%% = Words%%(WordNo%%, 1)
IF IndexN1%% THEN N1%% = N1%% + 1
ELSE
'Filled Grid
'Now check for all 26 letters of the alphabet
FOR J%% = 1 TO 13
FOR I%% = 1 TO 13
IF Grid%%(I%%, J%%) >= 1 THEN Words%%(Grid%%(I%%, J%%), 0) = True 'Zeroth position of Words%% used as marker for all letters present
NEXT I%%
NEXT J%%
K%% = 1
WHILE DoesFit%% AND K%% <= 26
IF NOT Words%%(K%%, 0) THEN DoesFit%% = False
K%% = K%% + 1
WEND
IF NOT DoesFit%% THEN
DoesFit%% = True 'To break out of this WHILE/WEND
WordNo%% = 1 'Start Again
END IF
END IF
END IF
IF CommonChoix% > 10000 THEN
DoesFit%% = True 'To break out of this WHILE/WEND
WordNo%% = 1 'Start Again
END IF
WEND
IF TIMER > Start! + 2.5 THEN
Start! = TIMER
RANDOMIZE (TIMER)
PRINT ".";
DotCount% = DotCount% + 1 'This IF condition does not often apply with the selected grids
IF DotCount% > 60 THEN
DotCount% = 0
PRINT ""
END IF
END IF
WEND
AtEnd! = TIMER
'Graphics Screen & Print Grid
Start! = TIMER
_TITLE "QB64 Cipher Crossword"
SCREEN _NEWIMAGE(828, 828, 32)
_SCREENMOVE 250, 50
_DEST 0
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
RESTORE ReadData
DIM CharOffsets%%(26)
FOR N%% = 1 TO 26
READ CharOffsets%%(N%%)
NEXT N%%
F& = _LOADFONT("arialbd.ttf", 48)
_FONT F&
LINE (50, 50)-(778, 778), , B
LINE (49, 49)-(779, 779), , B
FOR N%% = 1 TO 13
LINE (50 + 56 * N%%, 50)-(50 + 56 * N%%, 778)
LINE (50, 50 + 56 * N%%)-(778, 50 + 56 * N%%)
NEXT N%%
FOR J%% = 1 TO 13
FOR I%% = 1 TO 13
IF Grid%%(I%%, J%%) = -1 THEN
LINE (50 + 56 * (I%% - 1), 50 + 56 * (J%% - 1))-(50 + 56 * I%%, 50 + 56 * J%%), , BF
ELSE
_PRINTSTRING (55 + CharOffsets%%(Grid%%(I%%, J%%)) + 56 * (I%% - 1), 58 + 56 * (J%% - 1)), CHR$(Grid%%(I%%, J%%) + 64)
END IF
NEXT I%%
NEXT J%%
_FONT 16
_FREEFONT F&
PRINT " ";
PRINT "Grid:"; STR$(GridNo%%); ", (All Common),"; STR$(TriesCount~&); " Searches, Time Taken: "; STR$(AtEnd! - AtStart!); "s"
IF TriesCount~& = 1 THEN BEEP
END
ReadData:
'Character Offsets
' A,B,C,D,E,F,G,H,I, J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
DATA 5,5,6,5,7,7,4,6,17,9,6,8,3,6,4,7,3,5,7,7,5,6,0,7,5,8Cipher Crossword Puzzle
Code: (Select All)
'Cipher Crossword Puzzle by Magdha 2026-01-12 ex Qwerkey
'Solve the puzzle to complete the crossword
$EXEICON:'.\xword.ico'
CONST False = 0, True = NOT False
CONST ScreenX% = 910, ScreenY% = 720, G! = 0.1, H! = 100, TStep! = 0.8, ZOff% = -496
DIM XWord$(13, 13), Alphabet&(26, 2), Numbers&(26), RanPos%%(26), Code%%(13, 13), Hue%(26, 2)
DIM Chosen%%(26, 1), Flight!(25, 8), Soln$(13, 13), Grids$(10, 13, 13), G$(7), Offset%%(26, 2)
RANDOMIZE (TIMER)
'Colours
'1 Maroon
DATA 128,0,0
'2 Brown
DATA 165,42,42
'3 Red
DATA 255,0,0
'4 Coral
DATA 255,127,8
'5 Orange-Red
DATA 255,69,0
'6 Orange
DATA 255,165,0
'7 Dark Golden Rod
DATA 184,134,11
'8 Golden Rod
DATA 218,165,32
'9 Yellow
DATA 255,255,0
'10 Yellow-Grren
DATA 154,205,50
'11 Olive Drab
DATA 107,142,35
'12 chart reuse
DATA 127,255,0
'13 Green
DATA 0,255,0
'14 Lime Green
DATA 50,205,50
'15 Medium Spring Green
DATA 0,250,154
'16 Medium Sea Green
DATA 60,179,113
'17 Light Sea Green
DATA 32,178,170
'18 Dark Cyan
DATA 0,139,139
'19 Dodger Blue
DATA 30,144,255
'20 Cadet Blue
DATA 95,158,160
'21 Blue
DATA 0,0,255
'22 Dark Blue
DATA 0,0,160
'23 Indigo-Violet
DATA 112,0,171
'24 Dark Violet
DATA 148,0,211
'25 Purple
DATA 128,0,128
'26 Dark Purple
DATA 90,0,100
FOR N%% = 1 TO 26
FOR M%% = 0 TO 2
READ Hue%(N%%, M%%)
NEXT M%%
NEXT N%%
'Random Number assignment
FOR N%% = 1 TO 26
Place%% = INT(RND * 26) + 1
Empty%% = True
WHILE Empty%%
IF RanPos%%(Place%%) = 0 THEN
RanPos%%(Place%%) = N%%
Empty%% = False
ELSE
Place%% = Place%% + 1
IF Place%% > 26 THEN Place%% = 1
END IF
WEND
NEXT N%%
'Character Offsets
' A,B,C,D,E,F,G,H,I, J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
DATA 5,5,6,5,7,7,4,6,17,9,6,8,3,6,4,7,3,5,7,7,5,6,0,7,5,8
DATA 4,5,5,5,6,7,3,6,13,7,6,7,2,5,2,5,2,5,5,5,4,4,0,5,5,5
DATA 12,12,12,12,12,12,12,12,12,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FOR P%% = 0 TO 2
FOR N%% = 1 TO 26
READ Offset%%(N%%, P%%)
NEXT N%%
NEXT P%%
'Load Grid Data
OPEN "GridData.txt" FOR INPUT AS #1
FOR N%% = 0 TO 10
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
INPUT #1, Grids$(N%%, Column%%, Row%%)
NEXT Column%%
NEXT Row%%
INPUT #1, Dummy$
NEXT N%%
CLOSE #1
'Load Game Data
OPEN "game.rnd" FOR RANDOM AS #2 LEN = 16
FIELD #2, 2 AS G$(0), 2 AS G$(1), 2 AS G$(2), 2 AS G$(3), 2 AS G$(4), 2 AS G$(5), 2 AS G$(6), 2 AS G$(7)
GET #2, 1
GridNo%% = CVI(G$(0))
'Load Grid into Game
Seed%% = 1
Chosen%%(Seed%%, 0) = INT(RND * 26) + 1
Chosen%%(RanPos%%(Chosen%%(Seed%%, 0)), 1) = True
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
IF Grids$(GridNo%%, Column%%, Row%%) <> "*" THEN
IF (GridNo%% + 1) / 2 = (GridNo%% + 1) \ 2 THEN
XWord$(Column%%, Row%%) = CHR$(ASC(Grids$(GridNo%%, Column%%, Row%%)) - 27 + Column%%)
ELSE
XWord$(Column%%, Row%%) = CHR$(ASC(Grids$(GridNo%%, Column%%, Row%%)) - 27 + Row%%)
END IF
ELSE
XWord$(Column%%, Row%%) = "*"
END IF
IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", XWord$(Column%%, Row%%)) <> 0 THEN
ItsThisOne%% = False
N%% = 1
WHILE NOT ItsThisOne%%
IF RanPos%%(N%%) = ASC(XWord$(Column%%, Row%%)) - 64 THEN
ItsThisOne%% = True
ELSE
N%% = N%% + 1
END IF
WEND
Code%%(Column%%, Row%%) = N%%
END IF
IF Code%%(Column%%, Row%%) = Chosen%%(Seed%%, 0) THEN
Soln$(Column%%, Row%%) = XWord$(Column%%, Row%%)
Code%%(Column%%, Row%%) = 0
END IF
NEXT Column%%
NEXT Row%%
'Images
'Alphbet Images
FOR N%% = 1 TO 26
TempImg& = _NEWIMAGE(48, 48, 32)
_DEST TempImg&
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
_FONT _LOADFONT("arialbd.ttf", 50)
_PRINTSTRING (Offset%%(N%%, 0), 3), CHR$(N%% + 64)
Alphabet&(N%%, 2) = _COPYIMAGE(TempImg&)
Alphabet&(N%%, 0) = HardwareImage&(TempImg&)
TempImg& = _NEWIMAGE(44, 44, 32)
_DEST TempImg&
COLOR _RGBA(0, 0, 0, 150), _RGBA(255, 255, 255, 150)
CLS
LINE (0, 0)-(43, 43), , B
_FONT _LOADFONT("arialbd.ttf", 38)
_PRINTSTRING (Offset%%(N%%, 1) + 4, 5), CHR$(N%% + 64)
Alphabet&(N%%, 1) = HardwareImage&(TempImg&)
TempImg& = _NEWIMAGE(47, 38, 32)
_DEST TempImg&
COLOR _RGB32(Hue%(N%%, 0), Hue%(N%%, 1), Hue%(N%%, 2)), _RGB32(255, 255, 255)
CLS
_FONT _LOADFONT("arialbd.ttf", 40)
_PRINTSTRING (Offset%%(N%%, 2), 0), LTRIM$(STR$(N%%))
Numbers&(N%%) = HardwareImage&(TempImg&)
NEXT N%%
'Edge Image (for 3D tiles)
TempImg& = _NEWIMAGE(44, 4, 32)
_DEST TempImg&
COLOR _RGB(150, 150, 70), _RGB(200, 200, 90)
CLS
LINE (0, 0)-(3, 3), , B
Edge& = HardwareImage&(TempImg&)
'BlankingforLetterChoice Image
TempImg& = _NEWIMAGE(44, 44, 32)
_DEST TempImg&
COLOR _RGBA(0, 0, 0, 200), _RGBA(255, 255, 255, 200)
CLS
CantChoose& = HardwareImage&(TempImg&)
'NomdeGuerre Image
DeGuerre& = _NEWIMAGE(600, 40, 32)
_DEST DeGuerre&
COLOR _RGBA(205, 205, 225, 200), _RGBA(255, 255, 255, 0)
CLS
_FONT _LOADFONT("arialbd.ttf", 36)
FOR N%% = 1 TO 7
_PRINTSTRING (80 * N%%, 0), LEFT$(G$(N%%), 1)
NEXT N%%
'SolvedDisplay Image
TempImg& = _NEWIMAGE(520, 96, 32)
_DEST TempImg&
COLOR _RGBA(196, 196, 0, 200), _RGBA(255, 255, 255, 0)
CLS
_FONT _LOADFONT("arialbd.ttf", 120)
_PRINTSTRING (0, 0), "SOLVED!"
Complete& = HardwareImage&(TempImg&)
'QB64 Image
TempImg& = _NEWIMAGE(ScreenX%, ScreenY%, 32)
_DEST TempImg&
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
LINE (14, 14)-(705, 705), , B
LINE (15, 15)-(704, 704), , B
FOR Row%% = 1 TO 13
LINE (15, (15 + 53 * Row%%))-(704, (15 + 53 * Row%%))
NEXT Row%%
FOR Column%% = 1 TO 13
LINE ((15 + 53 * Column%%), 15)-(15 + (53 * Column%%), 704)
NEXT Column%%
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
'Grid 10
IF Grids$(10, Column%%, Row%%) = "*" THEN
LINE (15 + (53 * (Column%% - 1)), 15 + (53 * (Row%% - 1)))-(15 + (53 * Column%%), 15 + (53 * Row%%)), , BF
ELSE
Letter$ = CHR$(ASC(Grids$(10, Column%%, Row%%)) - 27 + Row%%)
_PUTIMAGE (18 + (53 * (Column%% - 1)), 18 + (53 * (Row%% - 1))), Alphabet&(ASC(Letter$) - 64, 2)
END IF
NEXT Column%%
NEXT Row%%
_FONT _LOADFONT("arialbd.ttf", 30)
_PRINTSTRING (722, 150), "An Example"
_PRINTSTRING (722, 200), "of a"
_PRINTSTRING (722, 250), "Completed"
_PRINTSTRING (722, 300), "Cipher"
_PRINTSTRING (722, 350), "Crossword"
_PRINTSTRING (722, 500), "Press"
_PRINTSTRING (722, 550), "Any Key"
QB64& = HardwareImage&(TempImg&)
FOR N%% = 1 TO 26
_FREEIMAGE Alphabet&(N%%, 2)
NEXT N%%
'Routine to Set Mouse Button (First Time Only)
_TITLE ("Set Mouse Button")
IF NOT _FILEEXISTS("mouse.cfg") THEN
Mousey& = _LOADIMAGE("CrosswordMouse.png", 32)
SCREEN _NEWIMAGE(500, 500, 32)
_SCREENMOVE 100, 100
_DEST 0
CLS
_PUTIMAGE (50, 100), Mousey&
LOCATE 2, 7
PRINT "Click on the mouse below with your normal button";
LOCATE 3, 5
PRINT "Click (not double-click) to make this screen disappear";
LOCATE 5, 6
PRINT "There may be a delay - Please wait for next screen";
CorrectButton%% = False
WHILE NOT CorrectButton%%
_LIMIT 60
'Assumes hardware has mouse buttons, value <=5
IF _MOUSEINPUT THEN
CorrectButton%% = False
MouseButton%% = 1
WHILE NOT CorrectButton%% AND MouseButton%% <= 5
IF _MOUSEBUTTON(MouseButton%%) THEN
CorrectButton%% = True
ELSE
MouseButton%% = MouseButton%% + 1
END IF
WEND
END IF
WEND
_FREEIMAGE Mousey&
OPEN "mouse.cfg" FOR OUTPUT AS #3
PRINT #3, MouseButton%%
CLOSE #3
_DELAY 0.2
DO 'Make sure that mouse button is released
Dum%% = _MOUSEINPUT
LOOP UNTIL NOT _MOUSEBUTTON(MouseButton%%)
_AUTODISPLAY
CLS
'Also a routine to rate processor would be good for future version
ELSE
OPEN "mouse.cfg" FOR INPUT AS #1
INPUT #1, MouseButton%%
CLOSE #1
END IF
_TITLE "QB64 Cipher Crossword Puzzle"
'Screen - hardware images only
SCREEN _NEWIMAGE(ScreenX%, ScreenY%, 32)
_SCREENMOVE 50, 50
_DEST 0
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
_DISPLAYORDER _HARDWARE
DoXWord%% = False
WHILE NOT DoXWord%%
_LIMIT 20
_PUTIMAGE (0, 0), QB64&
_DISPLAY
IF INKEY$ <> "" THEN
DoXWord%% = True
CLS
END IF
WEND
'Background Image
TempImg& = _NEWIMAGE(ScreenX%, ScreenY%, 32)
_DEST TempImg&
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
LINE (14, 14)-(705, 705), , B
LINE (15, 15)-(704, 704), , B
FOR Row%% = 1 TO 13
LINE (15, (15 + 53 * Row%%))-(704, (15 + 53 * Row%%))
NEXT Row%%
FOR Column%% = 1 TO 13
LINE ((15 + 53 * Column%%), 15)-(15 + (53 * Column%%), 704)
NEXT Column%%
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
IF XWord$(Column%%, Row%%) = "*" THEN LINE (15 + (53 * (Column%% - 1)), 15 + (53 * (Row%% - 1)))-(15 + (53 * Column%%), 15 + (53 * Row%%)), , BF
NEXT Column%%
NEXT Row%%
_FONT _LOADFONT("arialbd.ttf", 38)
LINE (769, 29)-(861, 616), _RGB(0, 0, 150), B
LINE (770, 30)-(860, 615), _RGB(0, 0, 150), B
FOR Column%% = 0 TO 1
FOR Row%% = 0 TO 12
LINE (770 + 45 * Column%%, 30 + 45 * Row%%)-(770 + 45 * (Column%% + 1), 30 + 45 * (Row%% + 1)), _RGB(0, 0, 150), B
_PRINTSTRING (775 + Offset%%(Column%% * 13 + Row%% + 1, 1) + 45 * Column%%, 36 + 45 * Row%%), CHR$(Column%% * 13 + Row%% + 65)
NEXT Row%%
NEXT Column%%
LINE (769, 616)-(861, 661), _RGB(0, 0, 150), B
LINE (770, 615)-(860, 660), _RGB(0, 0, 150), B
LINE (800, 615)-(800, 661), _RGB(0, 0, 150)
LINE (801, 615)-(801, 661), _RGB(0, 0, 150)
_PRINTSTRING (775, 621), "+"
_FONT _LOADFONT("arialbd.ttf", 10)
DATA R,E,S,T,A,R,T
FOR N%% = 1 TO 7
READ Letter$
_PRINTSTRING (797 + 8 * N%%, 614 + 5 * N%%), Letter$
NEXT N%%
LINE (769, 660)-(861, 700), _RGB(0, 0, 150), B
LINE (770, 661)-(860, 699), _RGB(0, 0, 150), B
_FONT _LOADFONT("arialbd.ttf", 30)
_PRINTSTRING (780, 668), "QUIT"
_MAPTRIANGLE (0, 0)-(599, 0)-(599, 39), DeGuerre& TO(747, 50)-(747, 649)-(708, 649)
_MAPTRIANGLE (0, 0)-(0, 39)-(599, 39), DeGuerre& TO(747, 50)-(708, 50)-(708, 649)
Grid& = HardwareImage&(TempImg&)
_FREEIMAGE DeGuerre&
Solved%% = False
Forward%% = False
Reverse%% = False
Picked%% = 0
T! = 0
Angle! = -2 * _PI
CanClick%% = True
ClickCount% = 0
WHILE DoXWord%%
_LIMIT 30
'Place Images
'Background Image
_PUTIMAGE (0, 0), Grid&
'Letter or Code Images
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
Letter$ = Soln$(Column%%, Row%%)
IF Letter$ <> "" THEN
_PUTIMAGE (18 + (53 * (Column%% - 1)), 18 + (53 * (Row%% - 1))), Alphabet&(ASC(Letter$) - 64, 0)
ELSEIF XWord$(Column%%, Row%%) <> "*" THEN
_PUTIMAGE (19 + (53 * (Column%% - 1)), 24 + (53 * (Row%% - 1))), Numbers&(Code%%(Column%%, Row%%))
END IF
NEXT Column%%
NEXT Row%%
'BlankChoice Images
FOR N%% = 1 TO 26
IF Chosen%%(N%%, 1) THEN _PUTIMAGE (771 + 45 * ((N%% - 1) \ 13), 31 + 45 * ((N%% - 1) MOD 13)), CantChoose&
NEXT N%%
'PickedUpLetter Image
IF Picked%% > 0 THEN _PUTIMAGE (XMouse% - 22, YMouse% - 22), Alphabet&(Picked%%, 1)
'AnimatedLetterLoad/Unload Images
IF Forward%% OR Reverse%% THEN
HalfSize%% = 22
FOR N%% = 0 TO P%%
Flight!(N%%, 7) = XStart% - CINT(Flight!(N%%, 1) * T! * COS(Flight!(N%%, 2)) * COS(Flight!(N%%, 3)))
Flight!(N%%, 8) = YStart% + CINT(Flight!(N%%, 1) * T! * COS(Flight!(N%%, 2)) * SIN(Flight!(N%%, 3)))
Flight!(N%%, 0) = CINT((Flight!(N%%, 1) * T! * SIN(Flight!(N%%, 2))) - (G! * T! * T! / 2))
Z0% = ZOff% + Flight!(N%%, 0)
Z1% = Z0% - 3
X1% = -HalfSize%% + Flight!(N%%, 7) - ScreenX% / 2
Y1% = -HalfSize%% + ScreenY% / 2 - Flight!(N%%, 8)
X2% = HalfSize%% + Flight!(N%%, 7) - ScreenX% / 2
Y2% = HalfSize%% + ScreenY% / 2 - Flight!(N%%, 8)
'Display Moving Letters as Solid Tile
_MAPTRIANGLE (0, 0)-(47, 0)-(47, 3), Edge& TO(X1%, Y1%, Z0%)-(X2%, Y1%, Z0%)-(X2%, Y1%, Z1%)
_MAPTRIANGLE (0, 0)-(0, 3)-(47, 3), Edge& TO(X1%, Y1%, Z0%)-(X1%, Y1%, Z1%)-(X2%, Y1%, Z1%)
_MAPTRIANGLE (0, 0)-(47, 0)-(47, 3), Edge& TO(X1%, Y2%, Z0%)-(X1%, Y1%, Z0%)-(X1%, Y1%, Z1%)
_MAPTRIANGLE (0, 0)-(0, 3)-(47, 3), Edge& TO(X1%, Y2%, Z0%)-(X1%, Y2%, Z1%)-(X1%, Y1%, Z1%)
_MAPTRIANGLE (0, 0)-(47, 0)-(47, 3), Edge& TO(X1%, Y2%, Z0%)-(X2%, Y2%, Z0%)-(X2%, Y2%, Z1%)
_MAPTRIANGLE (0, 0)-(0, 3)-(47, 3), Edge& TO(X1%, Y2%, Z0%)-(X1%, Y2%, Z1%)-(X2%, Y2%, Z1%)
_MAPTRIANGLE (0, 0)-(47, 0)-(47, 3), Edge& TO(X2%, Y2%, Z0%)-(X2%, Y1%, Z0%)-(X2%, Y1%, Z1%)
_MAPTRIANGLE (0, 0)-(0, 3)-(47, 3), Edge& TO(X2%, Y2%, Z0%)-(X2%, Y2%, Z1%)-(X2%, Y1%, Z1%)
_MAPTRIANGLE (0, 0)-(47, 0)-(47, 47), Alphabet&(Pick%%, 0) TO(X1%, Y2%, Z0%)-(X2%, Y2%, Z0%)-(X2%, Y1%, Z0%)
_MAPTRIANGLE (0, 0)-(0, 47)-(47, 47), Alphabet&(Pick%%, 0) TO(X1%, Y2%, Z0%)-(X1%, Y1%, Z0%)-(X2%, Y1%, Z0%)
NEXT N%%
IF Reverse%% THEN
T! = T! - TStep!
ELSE
T! = T! + TStep!
END IF
IF Flight!(0, 0) < 0 THEN
IF Reverse%% THEN
Reverse%% = False
Chosen%%(Pick%%, 1) = False
ELSE
Forward%% = False
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
IF Code%%(Column%%, Row%%) = Code%%(c%%, R%%) THEN
Soln$(Column%%, Row%%) = CHR$(Pick%% + 64)
END IF
NEXT Column%%
NEXT Row%%
END IF
END IF
END IF
'SolvedAnimation Image
IF Solved%% THEN
IF Angle! < 2 * _PI THEN
F! = (2 * _PI + Angle!) / (4 * _PI)
X1% = CINT(-260 * F! * COS(Angle!) + 48 * F! * SIN(Angle!)) + 360
Y1% = CINT(-260 * F! * SIN(Angle!) - 48 * F! * COS(Angle!)) + 360
X2% = CINT(260 * F! * COS(Angle!) + 48 * F! * SIN(Angle!)) + 360
Y2% = CINT(260 * F! * SIN(Angle!) - 48 * F! * COS(Angle!)) + 360
X3% = CINT(-260 * F! * COS(Angle!) - 48 * F! * SIN(Angle!)) + 360
Y3% = CINT(-260 * F! * SIN(Angle!) + 48 * F! * COS(Angle!)) + 360
X4% = CINT(260 * F! * COS(Angle!) - 48 * F! * SIN(Angle!)) + 360
Y4% = CINT(260 * F! * SIN(Angle!) + 48 * F! * COS(Angle!)) + 360
_MAPTRIANGLE (0, 0)-(519, 0)-(519, 95), Complete& TO(X1%, Y1%)-(X2%, Y2%)-(X4%, Y4%)
_MAPTRIANGLE (0, 0)-(0, 95)-(519, 95), Complete& TO(X1%, Y1%)-(X3%, Y3%)-(X4%, Y4%)
Angle! = Angle! + 4 * _PI / (5 * 30)
ELSE
_PUTIMAGE (100, 312), Complete&
END IF
END IF
_DISPLAY
'Mouse Input
WHILE _MOUSEINPUT
XMouse% = _MOUSEX: YMouse% = _MOUSEY
IF _MOUSEBUTTON(MouseButton%%) THEN
IF YMouse% >= 662 AND YMouse% <= 698 AND XMouse% >= 771 AND XMouse% <= 859 THEN
'Quit
DoXWord%% = False
ELSEIF NOT Forward%% AND NOT Reverse%% AND NOT Solved%% THEN
'Game Commands from Mouse Input
IF CanClick%% AND Picked%% = 0 AND YMouse% >= 31 AND YMouse% <= 614 AND XMouse% >= 771 AND XMouse% <= 859 THEN
'Pick a letter
Picked%% = (13 * ((XMouse% - 771) \ 45)) + ((YMouse% - 31) \ 45) + 1
CanClick%% = False
'Only allow unchosen letters
IF Chosen%%(Picked%%, 1) THEN Picked%% = 0
ELSEIF Picked%% = 0 AND YMouse% >= 16 AND YMouse% <= 703 AND XMouse% >= 16 AND XMouse% <= 703 THEN
'Delete a letter from the grid (& free up chosen letter)
c%% = (XMouse% - 16) \ 53 + 1
R%% = (YMouse% - 16) \ 53 + 1
IF CanClick%% AND Code%%(c%%, R%%) <> 0 AND Soln$(c%%, R%%) <> "" THEN
'Reverse Animation Initiation
CanClick%% = False
T! = 90.4 - 1.6
Reverse%% = True
Pick%% = ASC(Soln$(c%%, R%%)) - 64
XStart% = 771 + 22 + 45 * ((Pick%% - 1) \ 13)
YStart% = 31 + 22 + 45 * ((Pick%% - 1) MOD 13)
P%% = -1
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
IF Code%%(Column%%, Row%%) = Code%%(c%%, R%%) THEN
P%% = P%% + 1
Flight!(P%%, 4) = 16 + 24 + (53 * Column%% - 1)
Flight!(P%%, 5) = 16 + 24 + (53 * (Row%% - 1))
Soln$(Column%%, Row%%) = ""
END IF
NEXT Column%%
NEXT Row%%
FOR N%% = 0 TO P%%
Flight!(N%%, 0) = 0
Flight!(N%%, 6) = SQR((XStart% - Flight!(N%%, 4)) ^ 2 + (YStart% - Flight!(N%%, 5)) ^ 2)
Flight!(N%%, 2) = ATN(4 * H! / Flight!(N%%, 6))
Flight!(N%%, 1) = SQR(2 * G! * H!) / SIN(Flight!(N%%, 2))
Flight!(N%%, 3) = ATN((Flight!(N%%, 5) - YStart%) / (XStart% - Flight!(N%%, 4)))
NEXT N%%
END IF
ELSEIF CanClick%% AND Picked%% = 0 AND YMouse% >= 617 AND YMouse% <= 659 AND XMouse% >= 771 AND XMouse% <= 799 THEN
'Additional Seed (Restart Beforehand)
CanClick%% = False
Taken%% = True
WHILE Taken%%
N%% = INT(RND * 26) + 1
S%% = 1
Taken%% = False
WHILE NOT Taken%% AND S%% <= Seed%%
IF Chosen%%(S%%, 0) = N%% THEN
Taken%% = True
ELSE
S%% = S%% + 1
END IF
WEND
WEND
Seed%% = Seed%% + 1
Chosen%%(Seed%%, 0) = N%%
FOR S%% = 1 TO 26
Chosen%%(S%%, 1) = False
NEXT S%%
FOR S%% = 1 TO Seed%%
Chosen%%(RanPos%%(Chosen%%(S%%, 0)), 1) = True
NEXT S%%
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
Soln$(Column%%, Row%%) = ""
IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", XWord$(Column%%, Row%%)) <> 0 THEN
ItsThisOne%% = False
N%% = 1
WHILE NOT ItsThisOne%%
IF RanPos%%(N%%) = ASC(XWord$(Column%%, Row%%)) - 64 THEN
ItsThisOne%% = True
ELSE
N%% = N%% + 1
END IF
WEND
Code%%(Column%%, Row%%) = N%%
END IF
FOR S%% = 1 TO Seed%%
IF Code%%(Column%%, Row%%) = Chosen%%(S%%, 0) THEN
Soln$(Column%%, Row%%) = XWord$(Column%%, Row%%)
Code%%(Column%%, Row%%) = 0
END IF
NEXT S%%
NEXT Column%%
NEXT Row%%
ELSEIF CanClick%% AND Picked%% = 0 AND YMouse% >= 617 AND YMouse% <= 659 AND XMouse% >= 802 AND XMouse% <= 859 THEN
'Restart
CanClick%% = False
Seed%% = 1
FOR S%% = 1 TO 26
Chosen%%(S%%, 1) = False
NEXT S%%
Chosen%%(RanPos%%(Chosen%%(Seed%%, 0)), 1) = True
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
Soln$(Column%%, Row%%) = ""
IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", XWord$(Column%%, Row%%)) <> 0 THEN
ItsThisOne%% = False
N%% = 1
WHILE NOT ItsThisOne%%
IF RanPos%%(N%%) = ASC(XWord$(Column%%, Row%%)) - 64 THEN
ItsThisOne%% = True
ELSE
N%% = N%% + 1
END IF
WEND
Code%%(Column%%, Row%%) = N%%
END IF
IF Code%%(Column%%, Row%%) = Chosen%%(Seed%%, 0) THEN
Soln$(Column%%, Row%%) = XWord$(Column%%, Row%%)
Code%%(Column%%, Row%%) = 0
END IF
NEXT Column%%
NEXT Row%%
ELSEIF CanClick%% AND Picked%% > 0 THEN
'Place assigned letter
CanClick%% = False
IF YMouse% >= 16 AND YMouse% <= 703 AND XMouse% >= 16 AND XMouse% <= 703 THEN
'Look for unassigned letter
c%% = (XMouse% - 16) \ 53 + 1
R%% = (YMouse% - 16) \ 53 + 1
IF Soln$(c%%, R%%) <> "" OR XWord$(c%%, R%%) = "*" THEN
'Already assigned or Blank
Picked%% = 0
ELSE
'Tranfer Assigned Letter to All Appropriate Squares
'Initiate Forward Animation
Forward%% = True
Chosen%%(Picked%%, 1) = True
Pick%% = Picked%%
T! = 0
XStart% = 771 + 22 + 45 * ((Picked%% - 1) \ 13)
YStart% = 31 + 22 + 45 * ((Picked%% - 1) MOD 13)
P%% = -1
FOR Row%% = 1 TO 13
FOR Column%% = 1 TO 13
IF Code%%(Column%%, Row%%) = Code%%(c%%, R%%) THEN
P%% = P%% + 1
Flight!(P%%, 4) = 16 + 24 + (53 * (Column%% - 1))
Flight!(P%%, 5) = 16 + 24 + (53 * (Row%% - 1))
END IF
NEXT Column%%
NEXT Row%%
FOR N%% = 0 TO P%%
Flight!(N%%, 0) = 0
Flight!(N%%, 6) = SQR((XStart% - Flight!(N%%, 4)) ^ 2 + (YStart% - Flight!(N%%, 5)) ^ 2)
Flight!(N%%, 2) = ATN(4 * H! / Flight!(N%%, 6))
Flight!(N%%, 1) = SQR(2 * G! * H!) / SIN(Flight!(N%%, 2))
Flight!(N%%, 3) = ATN((Flight!(N%%, 5) - YStart%) / (XStart% - Flight!(N%%, 4)))
NEXT N%%
Picked%% = 0
END IF
ELSE
Picked%% = 0
END IF
END IF
END IF
END IF
WEND
'Check for Solution
IF NOT Forward%% AND NOT Reverse%% THEN
Solved%% = True
Row%% = 1: Column%% = 1
WHILE Solved%% AND Row%% <= 13
IF XWord$(Column%%, Row%%) = "*" THEN
'Do Nothing
Column%% = Column%% + 1
IF Column%% > 13 THEN
Column%% = 1
Row%% = Row%% + 1
END IF
ELSEIF XWord$(Column%%, Row%%) <> Soln$(Column%%, Row%%) THEN
Solved%% = False
ELSE
Column%% = Column%% + 1
IF Column%% > 13 THEN
Column%% = 1
Row%% = Row%% + 1
END IF
END IF
WEND
END IF
'Prevent false mouse clicks
IF NOT CanClick%% THEN
ClickCount% = ClickCount% + 1
IF ClickCount% = 10 THEN
CanClick%% = True
ClickCount% = 0
END IF
END IF
'Esc to Quit
K$ = INKEY$
IF K$ <> "" THEN
IF ASC(K$) = 27 THEN DoXWord%% = False
END IF
WEND
IF Solved%% THEN GridNo%% = GridNo%% + 1
IF GridNo%% > 9 THEN GridNo%% = 0
LSET G$(0) = MKI$(GridNo%%)
PUT #2, 1
CLOSE #2
SYSTEM
FUNCTION HardwareImage& (ImageName&)
HardwareImage& = _COPYIMAGE(ImageName&, 33)
_FREEIMAGE ImageName&
END FUNCTION