Print Page - Word search puzzle maker

_TITLE "Word Search Puzzle Maker by rfrost@mail.com"
' schemes:
' 0 fixed bonus for direction, each pass
' 1 random bonus each pass
' 2 random bonus each word
$EXEICON:'\icons\ws2.ico'
$CHECKING:OFF
DEFINT A-Z
_SCREENMOVE _MIDDLE
start! = TIMER: bestblanks = 9999: crlf$ = CHR$(13) + CHR$(10): totalwords = 103
RANDOMIZE TIMER
SCREEN 12
DIM word$(totalwords), board(25, 25), pdir(8), hdir(8), vdir(8), worth(8), worda(totalwords, 20), hc&(3, totalwords), pf(13, 4), ord(totalwords)
RESTORE tiny
FOR n = 0 TO 9 ' tiny font
READ g$
FOR i = 0 TO 4
READ z
pf(n, i) = z * 4096
NEXT i
NEXT n
FOR i = 1 TO totalwords
READ discard, word$(i)
NEXT i
IF _FILEEXISTS("ws.bst") THEN
OPEN "ws.bst" FOR INPUT AS #1
INPUT #1, bestwordsused, bestblanks
CLOSE
END IF
FOR word = 1 TO totalwords
ord(word) = word
word$(word) = UCASE$(word$(word))
worda(word, 0) = LEN(word$(word))
FOR j = 1 TO worda(word, 0)
worda(word, j) = ASC(MID$(word$(word), j, 1))
NEXT j
NEXT word
begin:
try& = try& + 1
scheme = VAL(RIGHT$(TIME$, 2)) \ 20 ' change every 20 seconds
CLS
GOSUB stats
ERASE board
FOR i = 0 TO 9 ' scramble word pointers a bit each time
z1 = RND * (totalwords - 1) + 1
z2 = RND * (totalwords - 1) + 1
IF z1 <> z2 THEN SWAP ord(z1), ord(z2)
NEXT i
RESTORE
FOR i = 1 TO 8 ' scheme 0
READ pdir(i), hdir(i), vdir(i), worth(i)
NEXT i
IF scheme = 1 THEN
FOR i = 1 TO 8
worth(i) = RND * 2
NEXT i
END IF
wordsused = 0
FOR word = 1 TO totalwords
GOSUB scankey
highscore = 0
pt = ord(word)
worda(pt, 0) = ABS(worda(pt, 0))
FOR row = 1 TO 25
FOR col = 1 TO 25
FOR dir = 1 TO 8
tscore = 0
FOR i = 1 TO worda(pt, 0)
tr = row + vdir(dir) * (i - 1)
tc = col + hdir(dir) * (i - 1)
IF (tr < 1) OR (tc < 1) OR (tr > 25) OR (tc > 25) THEN GOTO nextdir
wv = worda(pt, i)
bv = board(tr, tc)
IF (bv = 0) OR (bv = wv) THEN
tscore = tscore - (tscore = 0) - (bv = wv) * 10
ELSE
IF (i = 1) AND (bv <> 0) THEN GOTO nextcol
GOTO nextdir
END IF
NEXT i
IF tscore = 0 THEN GOTO nextdir
IF scheme < 2 THEN
tscore = tscore + worth(dir)
ELSE
tscore = tscore + RND * 2
END IF
flag = (tscore > highscore)
IF tscore = highscore THEN flag = -((RND * 100) > 96)
IF flag THEN highscore = tscore: sdir = dir: srow = row: scol = col
nextdir:
NEXT dir
nextcol:
NEXT col
NEXT row
IF highscore = 0 THEN
worda(pt, 0) = -worda(pt, 0) ' flag as not used
ELSE
COLOR pdir(sdir), 0 ' show word
FOR i = 1 TO worda(pt, 0)
tr = srow + (i - 1) * vdir(sdir)
tc = scol + (i - 1) * hdir(sdir)
board(tr, tc) = worda(pt, i)
IF blank = 0 THEN
LOCATE tr + 2, tc * 2 + 27
PRINT CHR$(board(tr, tc));
END IF
NEXT i
COLOR 7, 0
wordsused = wordsused + 1
END IF
NEXT word
hc&(scheme, wordsused) = hc&(scheme, wordsused) + 1
IF wordsused < bestwordsused THEN GOTO begin
numblanks = 0
FOR row = 1 TO 25
FOR col = 1 TO 25
numblanks = numblanks - (board(row, col) = 0)
NEXT col
NEXT row
IF (wordsused = bestwordsused) AND (numblanks >= bestblanks) THEN GOTO begin
bestblanks = numblanks: bestwordsused = wordsused
SOUND 400, 1
OPEN "ws.bst" FOR OUTPUT AS #1
PRINT #1, bestwordsused, bestblanks
CLOSE
OPEN "ws.top" FOR OUTPUT AS #1
PRINT #1, crlf$; crlf$; crlf$; crlf$;
FOR row = 1 TO 25
OutLine$ = SPACE$(50)
FOR col = 1 TO 25
IF board(row, col) = 0 THEN board(row, col) = RND(1) * 25 + 65 ' random character (you might want chr$(219) or similar)
MID$(OutLine$, (col - 1) * 2 + 1, 1) = CHR$(board(row, col))
NEXT col
PRINT #1, OutLine$; crlf$;
NEXT row
PRINT #1, crlf$; "Blanks ="; numblanks;
t$ = "Words used:" + STR$(wordsused)
PRINT #1, crlf$; crlf$; t$; crlf$; crlf$;
CharsPrinted = 0
FOR word = 1 TO totalwords
IF worda(word, 0) > 0 THEN
t$ = word$(word)
IF (CharsPrinted + LEN(t$)) > 79 THEN
PRINT #1, crlf$;
CharsPrinted = 0
END IF
PRINT #1, t$; " ";
CharsPrinted = CharsPrinted + LEN(t$) + 1
END IF
NEXT word
t$ = "Not used:" + STR$(totalwords - wordsused)
PRINT #1, crlf$; crlf$; t$; crlf$; crlf$;
CharsPrinted = 0
FOR word = 1 TO totalwords
IF worda(word, 0) < 0 THEN
t$ = word$(word)
IF (CharsPrinted + LEN(t$)) > 79 THEN
PRINT #1, crlf$;
CharsPrinted = 0
END IF
PRINT #1, t$; " ";
CharsPrinted = CharsPrinted + LEN(t$) + 1
END IF
NEXT word
PRINT #1, CHR$(12); ' printer eject
CLOSE #1
GOTO begin
scankey:
k = _KEYHIT
IF (k > 0) AND (k < 256) THEN
IF k = 32 THEN
SLEEP
DO: LOOP UNTIL INKEY$ = ""
END IF
IF k = ASC("b") THEN blank = blank XOR 1
IF k = ASC("p") THEN SHELL "copy ws.top prn >nul"
IF k = ASC("t") THEN SHELL "copy ws.top temp.top /y"
IF k = 27 THEN SYSTEM
END IF
RETURN
stats:
el! = TIMER - start!
IF el! < 0 THEN el! = (86400 - start!) + TIMER
start! = TIMER
et! = et! + el!
tet! = et!
u$ = "s"
IF tet! > 60 THEN tet! = tet! / 60: u$ = "m"
IF tet! > 60 THEN tet! = tet! / 60: u$ = "h"
s$ = SPACE$(3)
LOCATE 3, 1
PRINT s$; "Timer: ";: PRINT USING "#######.##"; tet!;: PRINT u$
PRINT s$; "Passes: ";: PRINT USING "##########"; try&
PRINT s$; "Avg pass:";: PRINT USING "#######.##"; et! / try&;: PRINT "s"
PRINT s$; "Last: ";: PRINT USING "##########"; wordsused
PRINT s$; "Grid: ";: PRINT USING "##########"; 25
PRINT s$; "Words: ";: PRINT USING "##########"; totalwords
z$ = STR$(bestwordsused) + "/" + LTRIM$(STR$(bestblanks))
PRINT s$; "Best:";: LOCATE CSRLIN, 23 - LEN(z$): PRINT z$
PRINT s$; "Output: ws.top"
IF blank THEN RETURN
y = 420: tc = 0 ' show count (with tiny font) for schemes
FOR i = 103 TO 0 STEP -1
IF (hc&(0, i) + hc&(1, i) + hc&(2, i)) > 0 THEN
z$ = RIGHT$(" " + STR$(i), 4) + SPACE$(50)
FOR j = 0 TO 2
n$ = RIGHT$(" " + STR$(hc&(j, i)), 6)
cc = j * 12 + 10
MID$(z$, cc, LEN(n$)) = n$
NEXT j
z$ = RTRIM$(z$)
IF tc = 7 THEN tc = 4 ELSE tc = 7
FOR j = 1 TO LEN(z$)
d$ = MID$(z$, j, 1)
IF d$ <> " " THEN
d = VAL(d$)
x = 20 + j * 4
FOR k = 0 TO 4
LINE (x, y + k)-(x + 4, y + k), tc, , pf(d, k)
NEXT k
END IF
NEXT j
y = y - 8
END IF
NEXT i
RETURN
DATA 4,1,0,0
DATA 9,1,1,0
DATA 10,0,1,0
DATA 11,-1,1,2
DATA 12,-1,0,1
DATA 13,-1,-1,2
DATA 14,0,-1,1
DATA 15,1,-1,1
tiny:
DATA 0,7,5,5,5,7
DATA 1,2,6,2,2,7
DATA 2,7,1,7,4,7
DATA 3,7,1,7,1,7
DATA 4,5,5,7,1,1
DATA 5,7,4,7,1,7
DATA 6,7,4,7,5,7
DATA 7,7,1,1,1,1
DATA 8,7,5,7,5,7
DATA 9,7,5,7,1,7
words:
DATA 89,actinium
DATA 13,aluminum
DATA 95,americium
DATA 51,antimony
DATA 18,argon
DATA 33,arsenic
DATA 85,astatine
DATA 56,barium
DATA 97,berkelium
DATA 4,beryllium
DATA 83,bismuth
DATA 5,boron
DATA 35,bromine
DATA 48,cadmium
DATA 20,calcium
DATA 98,californium
DATA 6,carbon
DATA 58,cerium
DATA 55,cesium
DATA 17,chlorine
DATA 24,chromium
DATA 27,cobalt
DATA 29,copper
DATA 96,curium
DATA 66,dysprosium
DATA 99,einsteinium
DATA 68,erbium
DATA 63,europium
DATA 100,fermium
DATA 9,florine
DATA 87,francium
DATA 64,gadolinium
DATA 31,gallium
DATA 32,germanium
DATA 79,gold
DATA 72,hafnium
DATA 2,helium
DATA 67,holmium
DATA 1,hydrogen
DATA 53,iodine
DATA 49,indium
DATA 77,iridium
DATA 26,iron
DATA 36,krypton
DATA 57,lanthanum
DATA 103,lawrencium
DATA 82,lead
DATA 3,lithium
DATA 71,lutetium
DATA 12,magnesium
DATA 25,manganese
DATA 101,mendelevium
DATA 80,mercury
DATA 42,molybdenum
DATA 60,neodymium
DATA 10,neon
DATA 93,neptunium
DATA 28,nickel
DATA 41,niobium
DATA 7,nitrogen
DATA 102,nobelium
DATA 76,osmium
DATA 8,oxygen
DATA 46,palladium
DATA 15,phosphorus
DATA 78,platinum
DATA 94,plutonium
DATA 84,pollonium
DATA 19,potassium
DATA 59,praseodymium
DATA 61,promethium
DATA 91,protactinium
DATA 86,radium
DATA 88,radon
DATA 75,rhenium
DATA 45,rhodium
DATA 37,rubidium
DATA 44,ruthenium
DATA 62,samarium
DATA 21,scandium
DATA 34,selenium
DATA 14,silicon
DATA 47,silver
DATA 11,sodium
DATA 38,strontium
DATA 16,sulfur
DATA 73,tantalum
DATA 43,technetium
DATA 52,tellurium
DATA 65,terbium
DATA 81,thallium
DATA 90,thorium
DATA 69,thulium
DATA 50,tin
DATA 22,titanium
DATA 74,tungsten
DATA 92,uranium
DATA 23,vanadium
DATA 54,xenon
DATA 39,yttrium
DATA 70,ytterbium
DATA 30,zinc
DATA 40,zirconium

QB64.org Forum

Active Forums => Programs => Topic started by: Richard Frost on November 24, 2019, 09:40:16 pm