Author Topic: Word search puzzle maker (Read 4265 times)

Richard Frost · « **on:** November 24, 2019, 09:40:16 pm »

Code: QB64: [Select]

_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

bplus · « **Reply #1 on:** November 25, 2019, 09:33:25 am »

Hi Richard Frost,

I had odd problem loading .ico? I saved code in same folder as .ico and removed path of .ico. Is there something special about .ico files or just another bone head blunder by yours truly?

Also any changes since I saw this last, a month or 2 ago from IRC, is the print even smaller or had my eyes gotten that much worse?

Update nothing special from Help:

It is a nice Icon, did you make that Richard?

Richard Frost · « **Reply #2 on:** November 25, 2019, 09:53:56 pm »

Sorry, no clue why that icon file doesn't work for you. Of course the path should be modified to where the file is.
The icon is quite optional anyway.

I adore that 3*5 font and use it whenever possible, and in this case had a valid reason - the ordinary font doesn't fit.

My best run for fitting all the words is 99 words with 66 spaces, which took about a week. Also, my average pass time
is 0.12 seconds. Working with the ASCII values is considerably faster than with text.

Any ideas to make it even faster, or smarter?

bplus · « **Reply #3 on:** November 25, 2019, 11:01:49 pm »

Quote

Any ideas to make it even faster, or smarter?

Easy, shorter words with lots of vowels to share. ;-))

Well I guess if you made that icon you would have been proud enough to admit it :D

I've had QB64 tell me many a time a file didn't exist and then change it's mind, but this one seems pretty set.

Is anyone else having problems loading the .ico file?

News:

Author Topic: Word search puzzle maker (Read 4265 times)

Richard Frost

Word search puzzle maker

bplus

Re: Word search puzzle maker

Richard Frost

Re: Word search puzzle maker

bplus

Re: Word search puzzle maker