Author Topic: Codeword solver (Read 2045 times)

david_uwi · « **on:** July 06, 2020, 07:18:43 am »

Code word is a type of puzzle that has appeared recently (maybe?).
It is like a crossword but there are no clues, instead the grid has numbers which correspond to letters of the alphabet (1 to 26 - not in order obviously).
You have to try to fit in words that will work in the grid and have one letter per number.
It is often difficult to get a start so I have written this program that will search a word list.
There are comment line at the beginning that explain the input.
As a hint longer words are often best as there are much fewer words with 10 letters than there are with 5 also the pattern of repeated and unique letters is larger. There is also a function to eliminate known letters, but this has not been tested.

Code: QB64: [Select]

OPEN "c:\cw1\dictionary_english.dic" FOR INPUT AS #1
DIM word$(320000)
DIM ii AS LONG
DIM q1 AS STRING * 1, q2 AS STRING * 1 'there are problems if these are not dimensioned
DIM wdot(25) AS STRING * 1, wndot(25) AS STRING * 1, wndot1(25) AS STRING * 1
DIM w2(7) AS STRING * 1, w3(7) AS STRING * 1, w4(7) AS STRING * 1, w5(7) AS STRING * 1
DIM ex1 AS STRING * 1
DIM r1$(20)
SCREEN _NEWIMAGE(1000, 500, 2)
 
'font1& = _LOADFONT("c:\windows\fonts\courbd.ttf", 20, "bold")  'courier bold
'font1& = _LOADFONT("c:\windows\fonts\times.ttf", 20, "bold") 'times bold
font1& = _LOADFONT("c:\windows\fonts\cour.ttf", 20, "bold") 'courier regular
_FONT font1& 'lets have a monospaced font - lines up better
 
'either put in the numbers in the puzzle separated by "," OR
'put in "." for unknowns and the numbers 2,3,4,5 for duplicates
'.2334.4N52.54 will work as will 13,8,21,21,4,16,4,N,3,8,10,3,4 [the N was a given letter]
'both will give differentiate
 
'when letters are given (or known) they can be excluded by loading an exclusion list
'input ! followed by the letters, this can be added to by ! [more letters] and reset by just putting in !
 
' **************************all duplicates MUST be put in**********************
'for crosswords this will not work!!!
PRINT "loading word list....please wait"
FOR i = 1 TO 319378
    INPUT #1, word$(i) 'load list into RAM it is much faster
NEXT i
CLOSE #1
CLS
DO
    200 PRINT "input word  ";
    LINE INPUT a$
    f$ = a$
    IF INSTR(a$, ",") <> 0 THEN GOSUB longform
    IF LEFT$(a$, 1) = "!" THEN
        IF LEN(a$) = 1 THEN ex$ = ""
        IF LEN(a$) > 1 THEN ex$ = RIGHT$(a$, LEN(a$) - 1) + ex$
        lex1 = LEN(ex$)
        IF lex1 > 0 THEN PRINT "exclusion list  "; ex$
        IF lex1 = 0 THEN PRINT "exclusion list reset"
        GOTO 200
    END IF
    x1 = LEN(a$)
    z$ = a$
    'z$ original input string
    'a$ input string with 2,3,..replaced by dots
    'b$ test string from word list
    FOR i = 1 TO x1
        IF ASC(MID$(a$, i, 1)) < 56 THEN MID$(a$, i, 1) = "."
    NEXT i
    exq$ = ""
    FOR i = 1 TO x1
        IF MID$(a$, i, 1) <> "." THEN exq$ = exq$ + MID$(a$, i, 1)
    NEXT i
    IF a$ = "end" THEN EXIT DO
    FOR ii = 1 TO 319378
        b$ = word$(ii)
        IF LEN(b$) = x1 THEN
            FOR i = 1 TO x1
                q1 = MID$(a$, i, 1)
                IF q1 <> "." THEN
                    q2 = MID$(b$, i, 1)
                    IF q1 <> q2 THEN 20
                END IF
            NEXT i
            k2 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "2" THEN
                    k2 = k2 + 1
                    w2(k2) = MID$(b$, i, 1)
                END IF
            NEXT i
            k3 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "3" THEN
                    k3 = k3 + 1
                    w3(k3) = MID$(b$, i, 1)
                END IF
            NEXT i
            k4 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "4" THEN
                    k4 = k4 + 1
                    w4(k4) = MID$(b$, i, 1)
                END IF
            NEXT i
            k5 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "5" THEN
                    k5 = k5 + 1
                    w5(k5) = MID$(b$, i, 1)
                END IF
            NEXT i
 
            kdot = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "." THEN
                    kdot = kdot + 1
                    wdot(kdot) = MID$(b$, i, 1)
                END IF
            NEXT i
            kndot = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 <> "." THEN
                    kndot = kndot + 1
                    wndot(kndot) = MID$(b$, i, 1)
                END IF
            NEXT i
            kndot1 = 0
            FOR i = 1 TO x1
                q1 = MID$(a$, i, 1)
                IF q1 <> "." THEN
                    kndot1 = kndot1 + 1
                    wndot1(kndot1) = MID$(a$, i, 1)
                END IF
            NEXT i
 
            'PRINT k2; k3; w2$(1): INPUT sa$
            'make sure all dots are different
            IF k2 <> 0 THEN
                FOR i = 1 TO k2 - 1
                    IF w2(i) <> w2(i + 1) THEN 20
                NEXT i
            END IF
 
            IF k3 <> 0 THEN
                FOR i = 1 TO k3 - 1
                    IF w3(i) <> w3(i + 1) THEN 20
                NEXT i
            END IF
            IF k4 <> 0 THEN
                FOR i = 1 TO k4 - 1
                    IF w4(i) <> w4(i + 1) THEN 20
                NEXT i
            END IF
            IF k5 <> 0 THEN
                FOR i = 1 TO k5 - 1
                    IF w5(i) <> w5(i + 1) THEN 20
                NEXT i
            END IF
 
            'now checking if any of the dots are the same as inputted letters
            IF kdot <> 0 THEN
                FOR i = 1 TO kdot - 1
                    FOR j = i + 1 TO kdot
 
                        IF wdot(i) = wdot(j) THEN 20
                    NEXT j
                NEXT i
            END IF
            FOR i = 1 TO kdot
                FOR j = 1 TO kndot
 
                    IF wdot(i) = wndot(j) THEN 20
                NEXT j
            NEXT i
            'now checking for duplicates in repeated letters
            x2 = INSTR(z$, "2")
            x3 = INSTR(z$, "3")
            x4 = INSTR(z$, "4")
            x5 = INSTR(z$, "5")
            IF x3 <> 0 THEN
                IF MID$(b$, x2, 1) = MID$(b$, x3, 1) THEN 20
            END IF
            IF x4 <> 0 THEN
                IF MID$(b$, x2, 1) = MID$(b$, x4, 1) THEN 20
                IF MID$(b$, x3, 1) = MID$(b$, x4, 1) THEN 20
            END IF
            IF k5 <> 0 THEN
                IF MID$(b$, x2, 1) = MID$(b$, x5, 1) THEN 20
                IF MID$(b$, x3, 1) = MID$(b$, x5, 1) THEN 20
                IF MID$(b$, x4, 1) = MID$(b$, x5, 1) THEN 20
 
            END IF
            'now check if any of the given letters are the same as multiples
            IF x2 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x2, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
            IF x3 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x3, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
            IF x4 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x4, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
            IF x5 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x5, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
 
 
 
            'use exclusion list if loaded
            IF lex1 > 0 THEN
                FOR ie = 1 TO lex1
                    ex1 = MID$(ex$, ie, 1)
                    IF INSTR(exq$, ex1) = 0 THEN 'lets not remove known letters
                        IF INSTR(b$, ex1) > 0 THEN 20
                    END IF
                NEXT ie
            END IF
            PRINT b$,
        END IF
    20 NEXT ii
 
    PRINT ""
LOOP
END
longform:
p0 = 1: kk = 0
r1$ = ""
r2$ = ""
DO
    kk = kk + 1
    p1 = INSTR(p0, a$, ",")
    IF p1 = 0 THEN
        r1$(kk) = MID$(f$, p0, LEN(f$) - p0 + 1)
        EXIT DO
    END IF
    r1$(kk) = MID$(f$, p0, p1 - p0)
    p0 = p1 + 1
LOOP
FOR nn = 1 TO kk
    'PRINT r1$(nn); ASC(r1$(nn))
NEXT nn
u1 = 0
FOR ii = 1 TO kk
    IF r1$(ii) = "." THEN 100
    IF LEN(r1$(ii)) = 3 THEN 100
    IF ASC(r1$(ii)) < 58 THEN
        FOR jj = ii + 1 TO kk
            IF r1$(jj) = "." THEN 120
            IF LEN(r1$(jj)) = 3 THEN 120
            IF ASC(r1$(jj)) < 58 THEN
                'PRINT r1$(ii); r1$(jj), ii; jj; LEN(r1$(jj)): INPUT sa$
                IF r1$(ii) = r1$(jj) THEN r1$(jj) = CHR$(50 + u1) + CHR$(50 + u1) + CHR$(50 + u1): u2 = 99
            END IF
 
        120 NEXT jj
        IF u2 = 0 THEN r1$(ii) = "."
        IF u2 = 99 THEN
            u2 = 0
            r1$(ii) = CHR$(50 + u1) + CHR$(50 + u1) + CHR$(50 + u1)
            u1 = u1 + 1
        END IF
    END IF
100 NEXT ii
f$ = ""
FOR ii = 1 TO kk
    IF LEN(r1$(ii)) = 3 THEN r1$(ii) = LEFT$(r1$(ii), 1)
 
    f$ = f$ + r1$(ii)
NEXT ii
a$ = f$
'PRINT a$, LEN(a$)
 
RETURN
 
'why does this get slower after several searches???
'changing q1$ to string*1 seems to solve it!

bplus · « **Reply #1 on:** July 06, 2020, 11:19:30 am »

Hi @david_uwi

I tried your code and ran smack into problem of not having Dictionary file, you might include that with your code in a .zip package or recommend a file to download (that your code can work with) from Internet.

david_uwi · « **Reply #2 on:** July 06, 2020, 11:31:12 am »

here's the word list I use (it is crap) I'm sure you can find a better one.
Change the number in the loading loop to the number of words in your word list of choice.

bplus · « **Reply #3 on:** July 06, 2020, 11:40:43 am »

Yes, I have a couple lists but your code appears to be using one of a particular size.

Right now I just wanted to see what you're doing, thanks for your copy.

Qwerkey · « **Reply #4 on:** July 06, 2020, 11:44:29 am »

David, you might be interested in my cipher crossword program

https://www.qb64.org/forum/index.php?topic=339.0

bplus · « **Reply #5 on:** July 06, 2020, 11:45:02 am »

Well the file you passed is password protected. 😒

david_uwi · « **Reply #6 on:** July 06, 2020, 12:09:10 pm »

Here it is unzipped. I downloaded it when I had very limited internet access. It has a lot of rubbish words and a few obvious missing word (particularly composite -see sweetpea and chequerboard).
I've just done an online search of codeword solvers and they use much the same notation as mine -maybe there is only so many way of doing it. Note my multiple letters start at 2 as 1 looked too much like a lower case L.

bplus · « **Reply #7 on:** July 06, 2020, 01:29:11 pm »

Well how long does this word input need to go on?

I put in about 2 dozen words and the last was "end" and that was that! This is not fun so far, maybe some more instruction please.

BTW the new file did work when I removed the path.

bplus · « **Reply #8 on:** July 06, 2020, 01:46:01 pm »

Yep more instruction needed, like is there a special code when inputting words to stop?

Code: QB64: [Select]

OPEN "dictionary_english.dic" FOR INPUT AS #1
DIM word$(320000)
DIM ii AS LONG
DIM q1 AS STRING * 1, q2 AS STRING * 1 'there are problems if these are not dimensioned
DIM wdot(25) AS STRING * 1, wndot(25) AS STRING * 1, wndot1(25) AS STRING * 1
DIM w2(7) AS STRING * 1, w3(7) AS STRING * 1, w4(7) AS STRING * 1, w5(7) AS STRING * 1
DIM ex1 AS STRING * 1
DIM r1$(20)
SCREEN _NEWIMAGE(1000, 500, 2)
 
'font1& = _LOADFONT("c:\windows\fonts\courbd.ttf", 20, "bold")  'courier bold
'font1& = _LOADFONT("c:\windows\fonts\times.ttf", 20, "bold") 'times bold
font1& = _LOADFONT("c:\windows\fonts\cour.ttf", 20, "bold") 'courier regular
_FONT font1& 'lets have a monospaced font - lines up better
 
'either put in the numbers in the puzzle separated by "," OR
'put in "." for unknowns and the numbers 2,3,4,5 for duplicates
'.2334.4N52.54 will work as will 13,8,21,21,4,16,4,N,3,8,10,3,4 [the N was a given letter]
'both will give differentiate
 
'when letters are given (or known) they can be excluded by loading an exclusion list
'input ! followed by the letters, this can be added to by ! [more letters] and reset by just putting in !
 
' **************************all duplicates MUST be put in**********************
'for crosswords this will not work!!!
PRINT "loading word list....please wait"
FOR i = 1 TO 319378
    INPUT #1, word$(i) 'load list into RAM it is much faster
NEXT i
CLOSE #1
CLS
DO
    '200 PRINT "input word  ";
    'LINE INPUT a$
 
    ' avoid tedious task of making up how ever many words this thing wants
    200 a$ = word$(INT(RND * 319378))
 
 
 
 
    f$ = a$
    IF INSTR(a$, ",") <> 0 THEN GOSUB longform
    IF LEFT$(a$, 1) = "!" THEN
        IF LEN(a$) = 1 THEN ex$ = ""
        IF LEN(a$) > 1 THEN ex$ = RIGHT$(a$, LEN(a$) - 1) + ex$
        lex1 = LEN(ex$)
        IF lex1 > 0 THEN PRINT "exclusion list  "; ex$
        IF lex1 = 0 THEN PRINT "exclusion list reset"
        GOTO 200
    END IF
    x1 = LEN(a$)
    z$ = a$
    'z$ original input string
    'a$ input string with 2,3,..replaced by dots
    'b$ test string from word list
    FOR i = 1 TO x1
        IF ASC(MID$(a$, i, 1)) < 56 THEN MID$(a$, i, 1) = "."
    NEXT i
    exq$ = ""
    FOR i = 1 TO x1
        IF MID$(a$, i, 1) <> "." THEN exq$ = exq$ + MID$(a$, i, 1)
    NEXT i
    IF a$ = "end" THEN EXIT DO
    FOR ii = 1 TO 319378
        b$ = word$(ii)
        IF LEN(b$) = x1 THEN
            FOR i = 1 TO x1
                q1 = MID$(a$, i, 1)
                IF q1 <> "." THEN
                    q2 = MID$(b$, i, 1)
                    IF q1 <> q2 THEN 20
                END IF
            NEXT i
            k2 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "2" THEN
                    k2 = k2 + 1
                    w2(k2) = MID$(b$, i, 1)
                END IF
            NEXT i
            k3 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "3" THEN
                    k3 = k3 + 1
                    w3(k3) = MID$(b$, i, 1)
                END IF
            NEXT i
            k4 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "4" THEN
                    k4 = k4 + 1
                    w4(k4) = MID$(b$, i, 1)
                END IF
            NEXT i
            k5 = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "5" THEN
                    k5 = k5 + 1
                    w5(k5) = MID$(b$, i, 1)
                END IF
            NEXT i
 
            kdot = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 = "." THEN
                    kdot = kdot + 1
                    wdot(kdot) = MID$(b$, i, 1)
                END IF
            NEXT i
            kndot = 0
            FOR i = 1 TO x1
                q1 = MID$(z$, i, 1)
                IF q1 <> "." THEN
                    kndot = kndot + 1
                    wndot(kndot) = MID$(b$, i, 1)
                END IF
            NEXT i
            kndot1 = 0
            FOR i = 1 TO x1
                q1 = MID$(a$, i, 1)
                IF q1 <> "." THEN
                    kndot1 = kndot1 + 1
                    wndot1(kndot1) = MID$(a$, i, 1)
                END IF
            NEXT i
 
            'PRINT k2; k3; w2$(1): INPUT sa$
            'make sure all dots are different
            IF k2 <> 0 THEN
                FOR i = 1 TO k2 - 1
                    IF w2(i) <> w2(i + 1) THEN 20
                NEXT i
            END IF
 
            IF k3 <> 0 THEN
                FOR i = 1 TO k3 - 1
                    IF w3(i) <> w3(i + 1) THEN 20
                NEXT i
            END IF
            IF k4 <> 0 THEN
                FOR i = 1 TO k4 - 1
                    IF w4(i) <> w4(i + 1) THEN 20
                NEXT i
            END IF
            IF k5 <> 0 THEN
                FOR i = 1 TO k5 - 1
                    IF w5(i) <> w5(i + 1) THEN 20
                NEXT i
            END IF
 
            'now checking if any of the dots are the same as inputted letters
            IF kdot <> 0 THEN
                FOR i = 1 TO kdot - 1
                    FOR j = i + 1 TO kdot
 
                        IF wdot(i) = wdot(j) THEN 20
                    NEXT j
                NEXT i
            END IF
            FOR i = 1 TO kdot
                FOR j = 1 TO kndot
 
                    IF wdot(i) = wndot(j) THEN 20
                NEXT j
            NEXT i
            'now checking for duplicates in repeated letters
            x2 = INSTR(z$, "2")
            x3 = INSTR(z$, "3")
            x4 = INSTR(z$, "4")
            x5 = INSTR(z$, "5")
            IF x3 <> 0 THEN
                IF MID$(b$, x2, 1) = MID$(b$, x3, 1) THEN 20
            END IF
            IF x4 <> 0 THEN
                IF MID$(b$, x2, 1) = MID$(b$, x4, 1) THEN 20
                IF MID$(b$, x3, 1) = MID$(b$, x4, 1) THEN 20
            END IF
            IF k5 <> 0 THEN
                IF MID$(b$, x2, 1) = MID$(b$, x5, 1) THEN 20
                IF MID$(b$, x3, 1) = MID$(b$, x5, 1) THEN 20
                IF MID$(b$, x4, 1) = MID$(b$, x5, 1) THEN 20
 
            END IF
            'now check if any of the given letters are the same as multiples
            IF x2 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x2, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
            IF x3 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x3, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
            IF x4 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x4, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
            IF x5 <> 0 THEN
                FOR j = 1 TO kndot1
                    IF MID$(b$, x5, 1) = wndot1(j) THEN 20
                NEXT j
            END IF
 
 
 
            'use exclusion list if loaded
            IF lex1 > 0 THEN
                FOR ie = 1 TO lex1
                    ex1 = MID$(ex$, ie, 1)
                    IF INSTR(exq$, ex1) = 0 THEN 'lets not remove known letters
                        IF INSTR(b$, ex1) > 0 THEN 20
                    END IF
                NEXT ie
            END IF
            PRINT b$,
        END IF
    20 NEXT ii
 
    PRINT ""
LOOP
END
 
 
longform:
p0 = 1: kk = 0
r1$ = ""
r2$ = ""
DO
    kk = kk + 1
    p1 = INSTR(p0, a$, ",")
    IF p1 = 0 THEN
        r1$(kk) = MID$(f$, p0, LEN(f$) - p0 + 1)
        EXIT DO
    END IF
    r1$(kk) = MID$(f$, p0, p1 - p0)
    p0 = p1 + 1
LOOP
FOR nn = 1 TO kk
    'PRINT r1$(nn); ASC(r1$(nn))
NEXT nn
u1 = 0
FOR ii = 1 TO kk
    IF r1$(ii) = "." THEN 100
    IF LEN(r1$(ii)) = 3 THEN 100
    IF ASC(r1$(ii)) < 58 THEN
        FOR jj = ii + 1 TO kk
            IF r1$(jj) = "." THEN 120
            IF LEN(r1$(jj)) = 3 THEN 120
            IF ASC(r1$(jj)) < 58 THEN
                'PRINT r1$(ii); r1$(jj), ii; jj; LEN(r1$(jj)): INPUT sa$
                IF r1$(ii) = r1$(jj) THEN r1$(jj) = CHR$(50 + u1) + CHR$(50 + u1) + CHR$(50 + u1): u2 = 99
            END IF
 
        120 NEXT jj
        IF u2 = 0 THEN r1$(ii) = "."
        IF u2 = 99 THEN
            u2 = 0
            r1$(ii) = CHR$(50 + u1) + CHR$(50 + u1) + CHR$(50 + u1)
            u1 = u1 + 1
        END IF
    END IF
100 NEXT ii
f$ = ""
FOR ii = 1 TO kk
    IF LEN(r1$(ii)) = 3 THEN r1$(ii) = LEFT$(r1$(ii), 1)
 
    f$ = f$ + r1$(ii)
NEXT ii
a$ = f$
'PRINT a$, LEN(a$)
 
RETURN
 
'why does this get slower after several searches???
'changing q1$ to string*1 seems to solve it!
 
 
 

This thing seems stuck in endless word input loop.

david_uwi · « **Reply #9 on:** July 06, 2020, 02:56:40 pm »

Yes it does take a while for all the words to load (I've got a SSD).
The searching is much quicker when loaded in RAM rather than on the hard drive so that is the reason for this.
Don't put in end as that is the word that I used to stop execution.
At the prompt put in .2334.4n52.54 (this was an actual example from a "sunday telegraph" puzzle)
the string indicates that there is a "N" in the middle (a known letter)
positions 2 and 9 are the same letter, positions 3 and 4 likewise 5,7 and 13 are the same 9 and 12 are also the same.
The dots represent single unknown letters.
In the actual codeword the numbers were 13,8,21,21,4,16,4,n,3,8,10,3,4 and this is also accepted as input.
Both will give just one word differentiate, which may be enough to solve (with a bit of thought) the whole puzzle.

bplus · « **Reply #10 on:** July 06, 2020, 03:29:36 pm »

Oh so this helps you solve puzzles you are working on from the paper! Sorry I thought you had some word game going.

Now I get it. Cool!

I did something similar for a Word Puzzle called the Scrambler, you unscramble the words and then used circled letters to solve a question from cartoon and caption that usually involves a clever pun.

News:

Author Topic: Codeword solver (Read 2045 times)

david_uwi

Codeword solver

bplus

Re: Code word solver

david_uwi

Re: Code word solver

bplus

Re: Code word solver

Qwerkey

Re: Code word solver

bplus

Re: Code word solver

david_uwi

Re: Code word solver

bplus

Re: Code word solver

bplus

Re: Code word solver

david_uwi

Re: Code word solver

bplus

Re: Code word solver