Happy Thanksgiving!

[B+]

Code: [Select]

'Word Search Puzzle.txt for JB [B+=MGA] 2016-11-23
' Let JB do this! Am I lazy or what?

'Ha! I was not counting on reverse searches as well,
'double trouble. I think I have a better approach to
'searches than this.

'found this in newspaper today "Thanksgiving Word Search"
data "OOCEPOTATOESCGDSMPEB"
data "MMMTKWDMNIKPMUPCPLPI"
data "WDOWIAGADWHYESOWRLII"
data "NTAVYLBYDDMWNRPGDTCB"
data "VESMIRGLIPCMNLMNCCEK"
data "KITAGRAVYAUUKEDIOVRT"
data "CASSEROLETCWRFGVNLFS"
data "LRTDANEMUOBTQTAIVUEQ"
data "TTYRVBKAPMMASOTGEFAF"
data "EHHEACDIHRWSTVHSRKSO"
data "VDUTLDAIKKUTUEEKSNTO"
data "ISARATIINBFYFRRNAAST"
data "TUNESSATFNKWFSIATHNB"
data "AOYRRDCEIMEBIRNHITEA"
data "NISGOBAAKOHRNLGTOYVL"
data "RCDNFCNYLSNYGFFWNTOL"
data "RIOIGHARARHSNNIKPAND"
data "HLWNBOOUOVEGETABLESQ"
data "FEGIUDQPMCDESSERTNYD"
data "PDADDSENOBHSIWPELEAF"
'qye yam to align reverse up diagonal
'ppi topright to yam
'words to find
data "ACORN AUTUMN BAKE BASTE CASSEROLE CONVERSATION"
data "CORNBREAD CORNUCOPIA DELICIOUS DESSERT DINING DINNER"
data "EAT FEAST FOOTBALL GATHERING GRAVY LEAF"
data "LEFTOVERS NAPKIN NATIVE OVEN PILGRIMS POTATOES"
data "PUMPKIN RECIPE SQUASH STUFFING TASTY THANKFUL"
data "THANKSGIVING THURSDAY TRADITIONS VEGETABLES WISHBONE YAM"

global xy
xy = 20 : nWords = 36 : wpl = 6 'words per line
dim L$(xy, xy), hL$(xy), rhL$(xy), vL$(xy), rvL$(xy), ddL$(2*xy-1), rddL$(2*xy-1), duL$(2*xy-1), rduL$(2*xy-1)
for y = 1 to xy 'horizontal strings and a block or letters
    read r$
    hL$(y) = r$
    rhL$(y) = reverse$(r$)
    for x = 1 to xy
        L$(x,y) = mid$(r$, x, 1)
        vL$(x) = vL$(x) + mid$(r$, x, 1)
        rvL$(x) = mid$(r$, x, 1) + rvL$(x)
    next
next
call showPuzzle
'for y = 1 to xy : print vL$(y) : next 'check vertical strings

dim W$(nWords)
for i = 1 to nWords/wpl
    read r$
    'notice r$
    for j = 1 to wpl
        W$( (i-1)*wpl + j ) = word$(r$, j)
    next
next

for i = 1 to 36
    locate 46 + (i-1) mod 2 * 17, int(i/2) + i mod 2
    print i;" ";W$(i)
next

'OK while this is displaying get the other arrays loaded

'ddL$ diagonal downs, start at end of top row work way to front then down
ix = 0
for x = xy to 1 step -1
    ix = ix + 1 : xx = x : yy = 1 : s$ = ""
    do
        s$ = s$ + L$(xx, yy)
        xx = xx + 1 : yy = yy + 1
    loop until xx > xy or yy > xy
    ddL$(ix) = s$
next
for y = 2 to xy
    ix = ix + 1 : xx = 1 : yy = y : s$ = ""
    do
        s$ = s$ + L$(xx, yy)
        xx = xx + 1 : yy = yy + 1
    loop until xx > xy or yy > xy
    ddL$(ix) = s$
next
'the reverse of above
for i = 1 to 2 * xy - 1
    rddL$(i) = reverse$(ddL$(i))
next

' duL$ start 1,1 work down the rows to xy then across the bottom
ix = 0
for y = 1 to xy
    ix = ix + 1 : xx = 1 : yy = y : s$ = ""
    do
        s$ = s$ + L$(xx, yy)
        xx = xx + 1 : yy = yy - 1
    loop until xx > xy or yy < 1
    duL$(ix) = s$
next

for x = 2 to xy
    ix = ix + 1 : xx = x : yy = xy : s$ = ""
    do
        s$ = s$ + L$(xx, yy)
        xx = xx + 1 : yy = yy - 1
    loop until xx > xy or yy < 1
    duL$(ix) = s$
next
'the reverse of above
for i = 1 to 2 * xy - 1
    rduL$(i) = reverse$(duL$(i))
next

'print:print:print  'check diagonal arrays
'for i = 1 to 2*xy-1 : print duL$(i) : next

for i = 1 to 36 'this time through find word, show word, star word
    locate 0, xy + 5 : print space$(40)
    locate 0, xy + 5 : print W$(i); :input "  press enter to show ";wayt
    call clearPuzzle
    if showWord(W$(i)) then
        locate 46 + (i-1) mod 2 * 17, int(i/2) + i mod 2
        print i;" ";W$(i);"*";
    end if
    locate 0, xy + 5 : print space$(40)
    locate 0, xy + 5 : print W$(i); :input "  OK, press enter ";wayt
    call showPuzzle
next
locate 10, xy + 7 : print "Happy Thanksgiving!"

sub showPuzzle
    locate 0,0
    for y = 1 to xy
        for x = 1 to xy
            print L$(x, y);" ";
        next
        print ">";chr$(96 + y)
    next
    locate 0, 22
    for x = 1 to 20 : print "V "; : next
    locate 0, 23
    for x = 1 to 20
        print chr$(96 + x);" ";
    next
    print
end sub

sub clearPuzzle
    for y= 1 to xy
        locate 0, y
        print space$(40)
    next
end sub

function showWord(find$)
    'find word in horizontal?
    for i = 1 to xy
        test = instr(hL$(i), find$)
        if test then 'found!
            locate test * 2 - 1, i
            for j = 1 to len(find$)
                print mid$(find$, j, 1);" ";
            next
            showWord = 1 : exit function
        end if
    next
    'find word in reverse horizontal?
    for i = 1 to xy
        test = instr(rhL$(i), find$)
        if test then 'found!
            for j = 1 to len(find$)
                locate (xy - test - j + 1) * 2 + 1, i
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    'find word in verticals
    for i = 1 to xy
        test = instr(vL$(i), find$)
        if test then 'found!
            for j = 1 to len(find$)
                locate i * 2 - 1, test + j - 1
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    'find word in reverse verticals
    for i = 1 to xy
        test = instr(rvL$(i), find$)
        if test then 'found!
            for j = 1 to len(find$)
                locate i * 2 - 1, xy - test - j + 2
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    'diagonals slanting up as go right
    for i = 1 to 2 * xy - 1
        test = instr(duL$(i), find$)
        if test then
            for j = 1 to len(find$)
                if i <= xy then
                    locate (test + j - 1) * 2 - 1, i - test - j + 2
                else
                    locate (i - xy + test + j - 1) * 2 - 1, xy - test - j + 2
                end if
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    'reverse up diagonal
    for i = 1 to 2 * xy - 1
        test = instr(rduL$(i), find$)
        if test then
            for j = 1 to len(find$)
                if i <= xy then
                    locate (i - test - j + 2) * 2 - 1, test + j - 1
                else
                    locate (xy - test -j + 2) * 2 - 1, i - xy + test + j - 1
                end if
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    'diagonal down to right
    for i = 1 to 2 * xy - 1
        test = instr(ddL$(i), find$)
        if test then
            for j = 1 to len(find$)
                if i <= xy then
                    locate (xy - i + test + j - 1) * 2 - 1, test + j - 1
                else
                    locate (test + j + -1) * 2 - 1, i - xy + test + j - 1
                end if
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    'reverse down diagonal
    for i = 1 to 2 * xy - 1
        test = instr(rddL$(i), find$)
        if test then
            for j = 1 to len(find$)
                if i <= xy then
                    locate (xy - test - j + 2 ) * 2 - 1, i - test - j + 2
                else
                    locate (2 * xy - i - test - j + 2) * 2 - 1,  xy - test - j + 2
                end if
                print mid$(find$, j, 1)
            next
            showWord = 1 : exit function
        end if
    next
    showWord = 0
end function

function reverse$(s$)
    if len(s$) then
        for i = 1 to len(s$)
            rtn$ = mid$(s$, i, 1) + rtn$
        next
        reverse$ = rtn$
    else
        reverse$ = ""
    end if
end function


[B+]

Big improvement on length of code, probably easier to follow too:

Code: [Select]

'Word Search 2.txt for JB [B+=MGA] 2016-11-24
' try another approach to Word Search
' Oh yeah! way better!

'found this in newspaper 2016-11-23 "Thanksgiving Word Search"
data "OOCEPOTATOESCGDSMPEB"
data "MMMTKWDMNIKPMUPCPLPI"
data "WDOWIAGADWHYESOWRLII"
data "NTAVYLBYDDMWNRPGDTCB"
data "VESMIRGLIPCMNLMNCCEK"
data "KITAGRAVYAUUKEDIOVRT"
data "CASSEROLETCWRFGVNLFS"
data "LRTDANEMUOBTQTAIVUEQ"
data "TTYRVBKAPMMASOTGEFAF"
data "EHHEACDIHRWSTVHSRKSO"
data "VDUTLDAIKKUTUEEKSNTO"
data "ISARATIINBFYFRRNAAST"
data "TUNESSATFNKWFSIATHNB"
data "AOYRRDCEIMEBIRNHITEA"
data "NISGOBAAKOHRNLGTOYVL"
data "RCDNFCNYLSNYGFFWNTOL"
data "RIOIGHARARHSNNIKPAND"
data "HLWNBOOUOVEGETABLESQ"
data "FEGIUDQPMCDESSERTNYD"
data "PDADDSENOBHSIWPELEAF"

'words to find
data "ACORN AUTUMN BAKE BASTE CASSEROLE CONVERSATION"
data "CORNBREAD CORNUCOPIA DELICIOUS DESSERT DINING DINNER"
data "EAT FEAST FOOTBALL GATHERING GRAVY LEAF"
data "LEFTOVERS NAPKIN NATIVE OVEN PILGRIMS POTATOES"
data "PUMPKIN RECIPE SQUASH STUFFING TASTY THANKFUL"
data "THANKSGIVING THURSDAY TRADITIONS VEGETABLES WISHBONE YAM"

global xy 'for square block of letters xy is one side of square
xy = 20 : nWords = 36 : wpl = 6 'words per line
dim L$(xy, xy), W$(nWords)
DX(1) =  1 : DY(1) =  0
DX(2) =  1 : DY(2) =  1
DX(3) =  0 : DY(3) =  1
DX(4) = -1 : DY(4) =  1
DX(5) = -1 : DY(5) =  0
DX(6) = -1 : DY(6) = -1
DX(7) =  0 : DY(7) = -1
DX(8) =  1 : DY(8) = -1

for y = 1 to xy 'read in block of letters
    read r$
    for x = 1 to xy
        L$(x,y) = mid$(r$, x, 1)
    next
next
call showPuzzle
for i = 1 to nWords/wpl 'read in list of words to find
    read r$
    for j = 1 to wpl
        W$( (i - 1) * wpl + j ) = word$(r$, j)
    next
next
for i = 1 to 36  'words not more than 12 letters?
    locate 2 * xy + 6 + (i-1) mod 2 * 17, int(i/2) + i mod 2
    print i;" ";W$(i)
next

for i = 1 to 36 'this time through find word, show word, star word
    locate 1, xy + 5 : print space$(40)
    locate 1, xy + 5 : print W$(i); :input "  press enter to show ";wayt
    call clearPuzzle
    if showWord(W$(i)) then
        locate 46 + (i-1) mod 2 * 17, int(i/2) + i mod 2
        print i;" ";W$(i);"*";
    end if
    locate 1, xy + 5 : print space$(40)
    locate 1, xy + 5 : print W$(i); :input "  OK, press enter ";wayt
    call showPuzzle
next
locate 10, xy + 7 : print "Happy Thanksgiving!"

sub showPuzzle
    locate 1, 1
    for y = 1 to xy
        for x = 1 to xy
            print L$(x, y);" ";
        next
        print ">";chr$(96 + y)
    next
    locate 1, xy + 1
    for x = 1 to xy : print "V "; : next
    locate 1, xy + 2
    for x = 1 to xy : print chr$(96 + x);" "; : next
    print
end sub

sub clearPuzzle
    for y = 1 to xy
        locate 0, y
        print space$(2 * xy)
    next
end sub

function showWord(find$)
    'first find a letter that matches the first
    'then at that x,y try each of 8 directions to see if find a match
    'be smart see if enough room to fit the find word before heading out
    'if find it print in upper left board section 1, 1
    first$ = mid$(find$, 1, 1) : lf1 = len(find$) - 1
    for y = 1 to xy
        for x = 1 to xy
            if L$(x,y) = first$ then
                for d = 1 to 8
                    b1 = lf1 * DX(d) + x > 0 and lf1 * DX(d) + x <= xy
                    b2 = lf1 * DY(d) + y > 0 and lf1 * DY(d) + y <= xy
                    if b1 and b2  then
                        b$ = first$ : xx = x + DX(d) : yy = y + DY(d)
                        for i = 2 to len(find$)
                            b$ = b$ + L$(xx, yy)
                            xx = xx + DX(d) : yy = yy + DY(d)
                        next
                        if b$ = find$ then 'show our result
                            for i = 1 to len(find$)
                                locate 2*x-1, y : print L$(x,y);
                                x = x + DX(d) : y = y + DY(d)
                            next
                            showWord = 1 : exit function
                        end if
                    end if
                next
            end if
        next
    next
    'if still here, couldn't find find$
    showWord = 0
end function