_TITLE "Word Search for Christmas 2020" 'by b+ mod 2020-12-06 modified from: ' Puzzle Builder #4 sort lists 2020-12-05.bas but no input files!
' 3 output files will be created in case you want kids the play same game from:
' 1. A list of search words
' 2. The Letter Puzzle grid
' 3. Solution of words start location and direction.
CONST AscA
= 97, WordLengthLimit
= 15 CONST ScreenWidth
= 1000, ScreenHeight
= 640
TYPE WordSearch
'having trouble tracking all Global shared variables for puzzle so here is that container FileTheme
AS STRING ' the theme name for + " Word List.txt" file we are doing GridSide
AS LONG ' number of letters per side of square grid GridSideM1
AS LONG ' grid size - 1 GridSideP2M1
AS LONG ' grid size ^ 2 - 1 GridLabel
AS STRING ' top and side labeling of letters grid NumWords
AS LONG ' number of words PlaceWordIndex
AS LONG ' current index of word we are working NumPlacedWords
AS LONG ' current number of placed words NumUnplacedWords
AS LONG 'count the disasters UnfilledCellF
AS LONG 'there are still unfilled cells F = Flag NumBestPlacedWords
AS LONG ' best number of placed words here is goal = NumWords
D
AS LONG ' direction 0 to 7 ie North, NorthEast, East, SouthEast... NorthWest
REDIM SHARED WS
AS WordSearch
' this is all shared variables of puzzle in a container REDIM SHARED Words
(1 TO 250) AS WordType
' essential info about each search word REDIM SHARED AscWord
(1 TO 250, WordLengthLimit
) ' break the word done to ASC numbers for each letter, speed up processing REDIM SHARED AscLetters
(0 TO WS.GridSideM1
, 0 TO WS.GridSideM1
) ' this is the ASC of the letters on the grid REDIM SHARED AscBestLetters
(0 TO WS.GridSideM1
, 0 TO WS.GridSideM1
) ' this is the ASC of the letters in the Best grid using the most words REDIM SHARED DX
(0 TO 7), DY
(0 TO 7), DString$
(0 TO 7) ' these are direction "adders" to x, y position to search in directions REDIM SHARED DirectionTotals
(0 TO 7) ' check direction counts for quality puzzle.
'======================================= Word Search File Base Name and Grid Size ================================================
' Make your word list file with: Some base name for theme + " Word List.txt"
' test file 2 Richard Frost started this theme to test his puzzles from which I learned much :)
'WS.FileTheme = "Elements" ' add suffix to your file " Word List.txt" <<<<<<<<<<<<<<<<<<<<<<<<< Input
'WS.GridSide = 30 ' <<<<<<<<<<<<<<<<<<<<<<<<< Input later 30 the maximum grid size
'WS.Filler = "bplus" ' <<<<<<<<<<<<<<< Input a personalization to hide in the puzzle
' test file 1 The reason this Word Builder was Built! for the naughty and nice nephews and nieces.
WS.FileTheme = "Christmas 2020" 'add suffix to your file " Word List.txt" <<<<<<<<<<<<<<<<<<<<<<<<< Input
WS.GridSide = 19 ' <<<<<<<<<<<<<<<<<<<<<<<<< Input later 30 the maximum grid size
WS.Filler = "SECRET" ' <<<<<<<<<<<<<<< Input a personalization to hide in the puzzle
'' test file 3 check a tiny puzzle
'WS.FileTheme = "The First Four Elements"
'WS.GridSide = 5 ' <<<<<<<<<<<<<<<<<<<<<<<<< Input later 30 the maximum grid size
'WS.Filler = "BPLUS" ' <<<<<<<<<<<<<<< Input a personalization to hide in the puzzle
DIM try
, c
, r
, y$
, puzzleFiled
InitializeOnce
WHILE try
< 100 'for long runs uncomment BEEP try = try + 1
RestartPuzzleFill
IF WS.PlaceWordIndex
> 0 THEN ShowPuzzle
WHILE WS.PlaceWordIndex
< WS.NumWords
WS.PlaceWordIndex = WS.PlaceWordIndex + 1
WS.UnfilledCellF = 0 ' set F that all are filled
PlaceWord
IF WS.NumPlacedWords
> WS.NumBestPlacedWords
THEN 'copy Letters$ into Best$ REDIM AscBestLetters
(0 TO WS.GridSideM1
, 0 TO WS.GridSideM1
) FOR r
= 0 TO WS.GridSideM1
FOR c
= 0 TO WS.GridSideM1
AscBestLetters(c, r) = AscLetters(c, r)
WS.NumBestPlacedWords = WS.NumPlacedWords
FOR r
= 1 TO WS.NumWords
' copy everything because we shuffle each time BestWords
(r
).S
= Words
(r
).S: BestWords
(r
).
Len = Words
(r
).
Len: BestWords
(r
).Placed
= Words
(r
).Placed
BestWords(r).X = Words(r).X: BestWords(r).Y = Words(r).Y: BestWords(r).D = Words(r).D
Sort BestWords()
IF WS.NumBestPlacedWords
= WS.NumWords
THEN ' automatic file if all words positioned in puzzle ShowBestPuzzle
LOCATE 37, 1:
PRINT " After "; TS$
(try
);
" tries, this complete puzzle was made." FilePuzzle
LOCATE 39, 1:
PRINT " Puzzle Filed, next up is word search.";
puzzleFiled = -1
ShowBestPuzzle
LOCATE 37, 1:
PRINT " After "; TS$
(try
);
" tries, this was best puzzle." LOCATE 38, 1:
INPUT " Enter y for yes, to save the best to file."; y$
FilePuzzle
LOCATE 40, 1:
PRINT " Next up is word search, press any to continue.";
' Now to find words in our best puzzle
DIM bestPuz
, mx
, my
, mb
, mIndex
, wIndex
, cnt
, hx
, hy
, wd
, sx
, sy
, navX$
, navY$
, navD$
, i
ShowBestPuzzle 'get a snapshot
bestPuz
= _NEWIMAGE(ScreenWidth
, ScreenHeight
, 32) mIndex = my
mIndex = my + 40
mIndex = my + 80
mIndex = 0
wIndex = 0: cnt = 0 ' convert mIndex to wIndex of BestWords
cnt = cnt + 1
IF Found
(BestWords
(wIndex
).S
, hx
, hy
, wd
) THEN 'high lite it black, yellow ConvertCR2Screen hx, hy, sx, sy ' tranlate array location to screen location and navigate column, row
ConvertCR2Nav hx, hy, wd, navX$, navY$, navD$
LOCATE 38, 1:
PRINT BestWords
(wIndex
).S;
" found at ("; navX$;
", "; navY$;
") going "; navD$
COLOR &HFF0000BB, &HFFFFFF00 hx = hx + DX(wd): hy = hy + DY(wd)
ConvertCR2Screen hx, hy, sx, sy
COLOR &HFFFFFFFF, &HFF000000
SUB InitializeOnce
' everything that needs to be done once to get going REDIM wd$
, i
, j
, fName$
, pLine$
'new order to favor diagonals placements first if possible
DX(0) = 1: DY(0) = 0: DString$(0) = "East"
DX(1) = 0: DY(1) = 1: DString$(1) = "South"
DX(2) = -1: DY(2) = 0: DString$(2) = "West"
DX(3) = 0: DY(3) = -1: DString$(3) = "North"
DX(4) = -1: DY(4) = 1: DString$(4) = "South West"
DX(5) = -1: DY(5) = -1: DString$(5) = "North West"
DX(6) = 1: DY(6) = 1: DString$(6) = "South East"
DX(7) = 1: DY(7) = -1: DString$(7) = "North East"
WS.GridSideM1 = WS.GridSide - 1
WS.GridSideP2M1 = WS.GridSide * WS.GridSide - 1
WS.GridLabel
= MID$(" 0 1 2 3 4 5 6 7 8 9 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", 1, WS.GridSide
* 2 + 2)
WS.NumWords = 0
WS.NumWords = WS.NumWords + 1
Words(WS.NumWords).S = wd$
Sort Words()
Words
(j
).
Len = LEN(Words
(j
).S
) AscWord
(j
, i
) = ASC(Words
(j
).S
, i
)
REDIM AscLetters
(0 TO WS.GridSideM1
, 0 TO WS.GridSideM1
) 'now that we have the right size
'Now make a Sorted Word List file of up to 3 Columns of 40 words from the capitalized, trimmed, sorted word list
fName$ = WS.FileTheme + " Sorted 3 Column Search Words.txt"
IF i
<= WS.NumWords
THEN MID$(pLine$
, 1, 20) = TS$
(i
) + ") " + Words
(i
).S
IF i
+ 40 <= WS.NumWords
THEN MID$(pLine$
, 21, 20) = TS$
(i
+ 40) + ") " + Words
(i
+ 40).S
IF i
+ 80 <= WS.NumWords
THEN MID$(pLine$
, 41, 20) = TS$
(i
+ 80) + ") " + Words
(i
+ 80).S
DATA baby
,bethlehem
,cards
,carols
,coal
,cookies
,december
,decorate
,eggnog
,elf
,eve
,festivities
,garland
,gifts
,green
DATA grinch
,holiday
,holly
,joseph
,joy
,lights
,mary
,magi
,manger
,nativity
,ornaments
,poinsettia
,red
,reindeer
,rudolph
DATA santa
,scrooge
,shepherd
,sleigh
,star
,stockings
,tidings
,tinsel
,tree
,toys
,wreath
,mistletoe
,candycane
,angel
DATA chimney
,fruitcake
,gingerbread
,greetings
,goodwill
,jingle
,jolly
,noel
,naughty
,nice
,party
DATA partridge
,ribbon
,bow
,helpers
,sweater
,wrap
,vacation
,workshop
,yuletide
WS.PlaceWordIndex = 0
WS.NumUnplacedWords = 0 'count the disasters
WS.NumPlacedWords = 0
FOR i
= 1 TO WS.NumWords
'clear positions of words Words(i).Placed = 0: Words(i).X = -1: Words(i).Y = -1: Words(i).D = -1
FOR r
= 0 TO WS.GridSideM1
' clear the letter numbers FOR c
= 0 TO WS.GridSideM1
AscLetters(c, r) = 32
FOR i
= WS.NumWords
TO 2 STEP -1 'shuffle the list of Words to load FOR j
= 0 TO WordLengthLimit
SWAP AscWord
(i
, j
), AscWord
(r
, j
) i = 0
WHILE i
< WS.NumWords
- 1 'order by word length i = i + 1
FOR j
= i
+ 1 TO WS.NumWords
FOR k
= 0 TO WordLengthLimit
SWAP AscWord
(i
, k
), AscWord
(j
, k
)
SUB ShowPuzzle
'this was needed to make sure finding the best puzzle was working correctly DIM i
, x
, y
, cnt
, notPlaced$
, cntUnplaced
notPlaced$ = ""
FOR i
= 3 TO 2 + WS.GridSide
FOR y
= 0 TO WS.GridSide
- 1 FOR x
= 0 TO WS.GridSide
- 1 FOR i
= 1 TO WS.PlaceWordIndex
cnt = cnt + 1
cntUnplaced = cntUnplaced + 1
notPlaced$ = notPlaced$ + Words(i).S + " "
LOCATE 38, 1:
PRINT "Not placed words: "; notPlaced$; cntUnplaced
LOCATE 39, 1:
PRINT "Last word: "; TS$
(WS.PlaceWordIndex
);
" "; Words
(WS.PlaceWordIndex
).S;
'SLEEP
DIM bestScore
, headScore
, tailScore
, y
, x
, d
, b1
, b2
, i
, spaceHeadF
, spaceTailF
bestScore = -1 ' going through entire array of AscLetters try every direction looking for best score = placement
FOR y
= 0 TO WS.GridSideM1
FOR x
= 0 TO WS.GridSideM1
spaceHeadF = 0 'every new word do this must be certain we have at least one cell empty
IF AscWord
(WS.PlaceWordIndex
, 1) = AscLetters
(x
, y
) OR AscLetters
(x
, y
) = 32 THEN IF AscWord
(WS.PlaceWordIndex
, 1) = AscLetters
(x
, y
) THEN headScore
= 15 IF AscLetters
(x
, y
) = 32 THEN headScore
= 0: WS.UnfilledCellF
= -1: spaceHeadF
= -1 'no points for blanks but may proceed spaceTailF = 0: tailScore = 0
b1
= x
+ DX
(d
) * (Words
(WS.PlaceWordIndex
).
Len - 1) >= 0 AND x
+ DX
(d
) * (Words
(WS.PlaceWordIndex
).
Len - 1) <= WS.GridSideM1
b2
= y
+ DY
(d
) * (Words
(WS.PlaceWordIndex
).
Len - 1) >= 0 AND y
+ DY
(d
) * (Words
(WS.PlaceWordIndex
).
Len - 1) <= WS.GridSideM1
FOR i
= 2 TO Words
(WS.PlaceWordIndex
).
Len IF AscWord
(WS.PlaceWordIndex
, i
) = AscLetters
(x
+ DX
(d
) * (i
- 1), y
+ DY
(d
) * (i
- 1)) THEN tailScore
= tailScore
+ 10 + (d
<= 3) * -1 + (d
> 3) * -(INT(RND * 4) + 1) ELSEIF AscLetters
(x
+ DX
(d
) * (i
- 1), y
+ DY
(d
) * (i
- 1)) = 32 THEN WS.UnfilledCellF = -1
spaceTailF = -1
tailScore = tailScore + (d > 1) * -1 + (d > 3) * -1 + (d > 6) * -.5
IF headScore
+ tailScore
> bestScore
AND (spaceHeadF
OR spaceTailF
) THEN 'make sure placing word over at least one empty spot Words(WS.PlaceWordIndex).X = x: Words(WS.PlaceWordIndex).Y = y: Words(WS.PlaceWordIndex).D = d
bestScore = headScore + tailScore 'local
skip:
'BEEP
IF bestScore
> -1 THEN 'we have a good place for this word put it there and update stuff FOR i
= 1 TO Words
(WS.PlaceWordIndex
).
Len AscLetters(DX(Words(WS.PlaceWordIndex).D) * (i - 1) + Words(WS.PlaceWordIndex).X,_
DY(Words(WS.PlaceWordIndex).D) * (i - 1) + Words(WS.PlaceWordIndex).Y) = ascWord(WS.PlaceWordIndex, i)
Words(WS.PlaceWordIndex).Placed = -1
WS.NumPlacedWords = WS.NumPlacedWords + 1
Words(WS.PlaceWordIndex).Placed = 0
WS.NumUnplacedWords = WS.NumUnplacedWords + 1
REDIM mMod
, m
, i
, j
, x
, y
, DirectionTotals
(0 TO 7), s$
(1 TO 4)
mMod
= LEN(WS.Filler
) ' FillBlanksInBest FOR y
= 0 TO WS.GridSide
- 1 FOR x
= 0 TO WS.GridSide
- 1 IF AscBestLetters
(x
, y
) = 32 THEN AscBestLetters
(x
, y
) = ASC(WS.Filler
, m
+ 1)
FOR i
= 3 TO 2 + WS.GridSide
FOR y
= 0 TO WS.GridSide
- 1 FOR x
= 0 TO WS.GridSide
- 1
j = j + 1
DirectionTotals(BestWords(i).D) = DirectionTotals(BestWords(i).D) + 1
s$(1) = " Total Norths: " + TS$(DirectionTotals(3)) + ", Total Souths: " + TS$(DirectionTotals(1))
s$(2) = " Total Easts: " + TS$(DirectionTotals(0)) + ", Total Wests: " + TS$(DirectionTotals(2))
s$(3) = " Total NWs: " + TS$(DirectionTotals(5)) + ", Total SWs: " + TS$(DirectionTotals(4))
s$(4) = " Total NEs: " + TS$(DirectionTotals(7)) + ", Total SEs: " + TS$(DirectionTotals(6))
REDIM i
, j
, r
, c
, b$
, x$
, y$
, d$
, s$
(1 TO 4)
FOR r
= 0 TO WS.GridSideM1
b$
= MID$(WS.GridLabel$
, r
* 2 + 4, 1) + " " FOR c
= 0 TO WS.GridSideM1
b$
= b$
+ CHR$(AscBestLetters
(c
, r
)) + " "
PRINT #1, " Search Word Solutions:" PRINT #1, " Words from: " + WS.FileTheme
+ " Word List.txt" PRINT #1, " First Letter Location and Direction:" j = j + 1
ConvertCR2Nav BestWords(i).X, BestWords(i).Y, BestWords(i).D, x$, y$, d$
PRINT #1, RIGHT$(" " + TS$
(j
), 4) + ") " + RIGHT$(SPC(15) + BestWords
(i
).S
, 15) + " (" + x$
+ ", " + y$
+ ") >>>---> " + d$
s$(1) = " Total Norths: " + TS$(DirectionTotals(3)) + ", Total Souths: " + TS$(DirectionTotals(1))
s$(2) = " Total Easts: " + TS$(DirectionTotals(0)) + ", Total Wests: " + TS$(DirectionTotals(2))
s$(3) = " Total NWs: " + TS$(DirectionTotals(5)) + ", Total SWs: " + TS$(DirectionTotals(4))
s$(4) = " Total NEs: " + TS$(DirectionTotals(7)) + ", Total SEs: " + TS$(DirectionTotals(6))
PRINT #1, " Message in unused letters: " + WS.Filler
FUNCTION Found
(word$
, headX
, headY
, direction
) 'First find a letter that matches the first letter in word$,
'then at that x, y try each of 8 directions to see if find a match.
'See if enough room to fit the find word before heading out to match letters.
DIM first$
, lenFind
, x
, y
, d
, b1
, b2
, xx
, yy
, b$
, i
first$
= MID$(word$
, 1, 1): lenFind
= LEN(word$
) - 1 FOR y
= 0 TO WS.GridSideM1
FOR x
= 0 TO WS.GridSideM1
FOR d
= 0 TO 7 'will word fit in this direction? 2 booleans True condition b1
= lenFind
* DX
(d
) + x
>= 0 AND lenFind
* DX
(d
) + x
<= WS.GridSideM1
b2
= lenFind
* DY
(d
) + y
>= 0 AND lenFind
* DY
(d
) + y
<= WS.GridSideM1
' build word from Letters block to see if matches word to find
b$ = first$: xx = x + DX(d): yy = y + DY(d)
b$
= b$
+ CHR$(AscBestLetters
(xx
, yy
)) xx = xx + DX(d): yy = yy + DY(d)
xx = x: yy = y 'copy x, y for rebuilding word on screen
IF b$
= word$
THEN 'found one show our result headX = x: headY = y: direction = d: Found = -1
SUB ConvertCR2Screen
(c
, r
, screenC
, screenR
) screenC = 2 * c + 4: screenR = r + 3
SUB ConvertCR2Nav
(c
, r
, d
, navX$
, navY$
, navD$
) navD$ = DString$(d)
SUB Sort
(arr
() AS WordType
) FOR i
= 1 TO WS.NumWords
- 1 FOR j
= i
+ 1 TO WS.NumWords
FUNCTION TS$
(n
) ' this shorthand for TrimString and I want it shorthand!
