Word search: Difference between revisions

=={{header|FreeBASIC}}==

{{trans|QB64}}

<lang freebasic>

Randomize Timer ' OK getting a good puzzle every time

'overhauled

Dim Shared As Byte LengthLimit(3 To 10) 'reset in Initialize, track and limit longer words

'LoadWords opens file of words and sets

Dim Shared As Integer NWORDS 'set in LoadWords, number of words with length: > 2 and < 11 and just letters

' word file words (shuffled) to be fit into puzzle and index position

Dim Shared As String WORDSSS(1 To 24945), CWORDSSS(1 To 24945)

Dim Shared As Integer WORDSINDEX 'the file has 24945 words but many are unsuitable

'words placed in Letters grid, word itself (WSS) x, y head (WX, WY) and direction (WD), WI is the index to all these

Dim Shared As String WSS(1 To 100)

Dim Shared As Byte WX(1 To 100), WY(1 To 100), WD(1 To 100), WI

' letters grid and direction arrays

Dim Shared As String LSS(0 To 9, 0 To 9)

Dim Shared As Byte DX(0 To 7), DY(0 To 7)

DX(0) = 1: DY(0) = 0

DX(1) = 1: DY(1) = 1

DX(2) = 0: DY(2) = 1

DX(3) = -1: DY(3) = 1

DX(4) = -1: DY(4) = 0

DX(5) = -1: DY(5) = -1

DX(6) = 0: DY(6) = -1

DX(7) = 1: DY(7) = -1

'to store all the words found embedded in the grid LSS()

Dim Shared As String ALLSS(1 To 200)

Dim Shared As Byte AllX(1 To 200), AllY(1 To 200), AllD(1 To 200) 'to store all the words found embedded in the grid LSS()

Dim Shared As Integer ALLindex

' signal successful fill of puzzle

Dim Shared FILLED As Boolean

FILLED = 0

Dim As Byte try

try = 1

Sub LoadWords

Dim As String wdSS

Dim As Integer i, m

Dim ok As Boolean

Open "unixdict.txt" For Input As #1

While Eof(1) = 0

Input #1, wdSS

If Len(wdSS) > 2 And Len(wdSS) < 11 Then

ok = -1

For m = 1 To Len(wdSS)

If Asc(wdSS, m) < 97 Or Asc(wdSS, m) > 122 Then ok = 0: Exit For

Next

If ok Then i += 1: WORDSSS(i) = wdSS: CWORDSSS(i) = wdSS

End If

Wend

Close #1

NWORDS = i

End Sub

Sub Shuffle

Dim As Integer i, r

For i = NWORDS To 2 Step -1

r = Int(Rnd * i) + 1

Swap WORDSSS(i), WORDSSS(r)

Next i

End Sub

Sub Initialize

Dim As Byte r, c'', x, y, d

Dim As String wdSS

For r = 0 To 9

For c = 0 To 9

LSS(c, r) = " "

Next c

Next r

'reset word arrays by resetting the word index back to zero

WI = 0

'fun stuff for me but doubt others would like that much fun!

'pluggin "basic", 0, 0, 2

'pluggin "plus", 1, 0, 0

'to assure the spreading of ROSETTA CODE

LSS(Int(Rnd * 5) + 5, 0) = "R": LSS(Int(Rnd * 9) + 1, 1) = "O"

LSS(Int(Rnd * 9) + 1, 2) = "S": LSS(Int(Rnd * 9) + 1, 3) = "E"

LSS(1, 4) = "T": LSS(9, 4) = "T": LSS(Int(10 * Rnd), 5) = "A"

LSS(Int(10 * Rnd), 6) = "C": LSS(Int(10 * Rnd), 7) = "O"

LSS(Int(10 * Rnd), 8) = "D": LSS(Int(10 * Rnd), 9) = "E"

'reset limits

LengthLimit(3) = 200

LengthLimit(4) = 6

LengthLimit(5) = 3

LengthLimit(6) = 2

LengthLimit(7) = 1

LengthLimit(8) = 0

LengthLimit(9) = 0

LengthLimit(10) = 0

'reset word order

Shuffle

End Sub

'for fun plug-in of words

Sub pluggin (wdSS As String, x As Integer, y As Integer, d As Integer)

For i As Byte = 0 To Len(wdSS) - 1

LSS(x + i * DX(d), y + i * DY(d)) = Mid(wdSS, i + 1, 1)

Next i

WI += WI

WSS(WI) = wdSS: WX(WI) = x: WY(WI) = y: WD(WI) = d

End Sub

Function TrmSS (n As Integer) As String

TrmSS = Rtrim(Ltrim(Str(n)))

End Function

'used in PlaceWord

Function CountSpaces () As Integer

Dim As Byte x, y

Dim count As Integer

For y = 0 To 9

For x = 0 To 9

If LSS(x, y) = " " Then count += 1

Next x

Next y

CountSpaces = count

End Function

Sub ShowPuzzle

Dim As Byte i, x, y

Dim As String wateSS

Cls

Print " 0 1 2 3 4 5 6 7 8 9"

Locate 3, 1

For i = 0 To 9

Print TrmSS(i)

Next i

For y = 0 To 9

For x = 0 To 9

Locate y + 3, 2 * x + 5: Print LSS(x, y)

Next x

Next y

For i = 1 To WI

If i < 20 Then

Locate i + 1, 30: Print TrmSS(i); " "; WSS(i)

Elseif i < 40 Then

Locate i - 20 + 1, 45: Print TrmSS(i); " "; WSS(i)

Elseif i < 60 Then

Locate i - 40 + 1, 60: Print TrmSS(i); " "; WSS(i)

End If

Next i

Locate 18, 1: Print "Spaces left:"; CountSpaces

Locate 19, 1: Print NWORDS

Locate 20, 1: Print Space(16)

If WORDSINDEX Then Locate 20, 1: Print TrmSS(WORDSINDEX); " "; WORDSSS(WORDSINDEX)

'LOCATE 15, 1: INPUT "OK, press enter... "; wateSS

End Sub

'used in PlaceWord

Function Match (word As String, template As String) As Integer

Dim i As Integer

Dim c As String

Match = 0

If Len(word) <> Len(template) Then Exit Function

For i = 1 To Len(template)

If Asc(template, i) <> 32 And (Asc(word, i) <> Asc(template, i)) Then Exit Function

Next

Match = -1

End Function

'heart of puzzle builder

Sub PlaceWord

' place the words randomly in the grid

' start at random spot and work forward or back 100 times = all the squares

' for each open square try the 8 directions for placing the word

' even if word fits Rossetta Challenge task requires leaving 11 openings to insert ROSETTA CODE,

' exactly 11 spaces needs to be left, if/when this occurs FILLED will be set true to signal finished to main loop

' if place a word update LSS, WI, WSS(WI), WX(WI), WY(WI), WD(WI)

Dim As String wdSS, templateSS, wateSS

Dim As Byte wLen, spot, testNum, rdir

Dim As Byte x, y, d, dNum, rdd, i, j

Dim As Boolean b1, b2

wdSS = WORDSSS(WORDSINDEX) 'the right side is all shared

'skip too many long words

If LengthLimit(Len(wdSS)) Then LengthLimit(Len(wdSS)) += 1 Else Exit Sub 'skip long ones

wLen = Len(wdSS) - 1 ' from the spot there are this many letters to check

spot = Int(Rnd * 100) ' a random spot on grid

testNum = 1 ' when this hits 100 we've tested all possible spots on grid

If Rnd < .5 Then rdir = -1 Else rdir = 1 ' go forward or back from spot for next test

While testNum < 101

y = Int(spot / 10)

x = spot Mod 10

If LSS(x, y) = Mid(wdSS, 1, 1) Or LSS(x, y) = " " Then

d = Int(8 * Rnd)

If Rnd < .5 Then rdd = -1 Else rdd = 1

dNum = 1

While dNum < 9

'will wdSS fit? from at x, y

templateSS = ""

b1 = wLen * DX(d) + x >= 0 And wLen * DX(d) + x <= 9

b2 = wLen * DY(d) + y >= 0 And wLen * DY(d) + y <= 9

If b1 And b2 Then 'build the template of letters and spaces from Letter grid

For i = 0 To wLen

templateSS += LSS(x + i * DX(d), y + i * DY(d))

Next

If Match(wdSS, templateSS) Then 'the word will fit but does it fill anything?

For j = 1 To Len(templateSS)

If Asc(templateSS, j) = 32 Then 'yes a space to fill

For i = 0 To wLen

LSS(x + i * DX(d), y + i * DY(d)) = Mid(wdSS, i + 1, 1)

Next

WI += 1

WSS(WI) = wdSS: WX(WI) = x: WY(WI) = y: WD(WI) = d

If CountSpaces = 0 Then FILLED = -1

Exit Sub 'get out now that word is loaded

End If

Next

'if still here keep looking

End If

End If

d = (d + 8 + rdd) Mod 8

dNum += 1

Wend

End If

spot = (spot + 100 + rdir) Mod 100

testNum += 1

Wend

End Sub

Sub FindAllWords

Dim As String wdSS, templateSS, wateSS

Dim As Byte wLen, x, y, d, j

Dim As Boolean b1, b2

For i As Integer = 1 To NWORDS

wdSS = CWORDSSS(i)

wLen = Len(wdSS) - 1

For y = 0 To 9

For x = 0 To 9

If LSS(x, y) = Mid(wdSS, 1, 1) Then

For d = 0 To 7

b1 = wLen * DX(d) + x >= 0 And wLen * DX(d) + x <= 9

b2 = wLen * DY(d) + y >= 0 And wLen * DY(d) + y <= 9

If b1 And b2 Then 'build the template of letters and spaces from Letter grid

templateSS = ""

For j = 0 To wLen

templateSS += LSS(x + j * DX(d), y + j * DY(d))

Next j

If templateSS = wdSS Then 'founda word

'store it

ALLindex += 1

ALLSS(ALLindex) = wdSS: AllX(ALLindex) = x: AllY(ALLindex) = y: AllD(ALLindex) = d

'report it

Locate 22, 1: Print Space(50)

Locate 22, 1: Print "Found: "; wdSS; " ("; TrmSS(x); ", "; TrmSS(y); ") >>>---> "; TrmSS(d);

Input " Press enter...", wateSS

End If

End If

Next d

End If

Next x

Next y

Next i

End Sub

Sub FilePuzzle

Dim As Byte i, r, c

Dim As String bSS

Open "WS Puzzle.txt" For Output As #1

Print " 0 1 2 3 4 5 6 7 8 9"

Print ""

For r = 0 To 9

bSS = TrmSS(r) + " "

For c = 0 To 9

bSS += LSS(c, r) + " "

Next c

Print bSS

Next r

Print ""

Print "Directions >>>---> 0 = East, 1 = SE, 2 = South, 3 = SW, 4 = West, 5 = NW, 6 = North, 7 = NE"

Print ""

Print " These are the items from unixdict.txt used to build the puzzle:"

Print ""

For i = 1 To WI Step 2

Print Right(Space(7) + TrmSS(i), 7); ") "; Right(Space(7) + WSS(i), 10); " ("; TrmSS(WX(i)); ", "; TrmSS(WY(i)); ") >>>---> "; TrmSS(WD(i));

If i + 1 <= WI Then

Print Right(Space(7) + TrmSS(i + 1), 7); ") "; Right(Space(7) + WSS(i + 1), 10); " ("; TrmSS(WX(i + 1)); ", "; TrmSS(WY(i + 1)); ") >>>---> "; TrmSS(WD(i + 1))

Else

Print ""

End If

Next

Print ""

Print " These are the items from unixdict.txt found embedded in the puzzle:"

Print ""

For i = 1 To ALLindex Step 2

Print Right(Space(7) + TrmSS(i), 7); ") "; Right(Space(7) + ALLSS(i), 10); " ("; TrmSS(AllX(i)); ", "; TrmSS(AllY(i)); ") >>>---> "; TrmSS(AllD(i));

If i + 1 <= ALLindex Then

Print Right(Space(7) + TrmSS(i + 1), 7); ") "; Right(Space(7) + ALLSS(i + 1), 10); " ("; TrmSS(AllX(i + 1)); ", "; TrmSS(AllY(i + 1)); ") >>>---> "; TrmSS(AllD(i + 1))

Else

Print ""

End If

Next i

Close #1

End Sub

LoadWords 'this sets NWORDS count to work with

While try < 11

Initialize

ShowPuzzle

For WORDSINDEX = 1 To NWORDS

PlaceWord

ShowPuzzle

If FILLED Then Exit For

Next WORDSINDEX

If FILLED And WI > 24 Then

FindAllWords

FilePuzzle

Locate 23, 1: Print "On try #"; TrmSS(try); " a successful puzzle was built and filed."

Exit While

Else

try += 1

End If

Wend

If FILLED = 0 Then Locate 23, 1: Print "Sorry, 10 tries and no success."

End

</lang>

{{out}}

<pre>

Igual que la entrada de QB64.

</pre>