360 lines
12 KiB
Plaintext
360 lines
12 KiB
Plaintext
Randomize Timer ' OK getting a good puzzle every time
|
|
|
|
#Macro TrmSS (n)
|
|
LTrim(Str(n))
|
|
#EndMacro
|
|
|
|
'overhauled
|
|
Dim Shared As ULong LengthLimit(3 To 10) 'reset in Initialize, track and limit longer words
|
|
|
|
'LoadWords opens file of words and sets
|
|
Dim Shared As ULong 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 ULong 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 ULong 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 Long 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 ULong 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 ULong ALLindex
|
|
|
|
' signal successful fill of puzzle
|
|
Dim Shared FILLED As Boolean
|
|
Dim Shared As ULong try = 1
|
|
|
|
Sub LoadWords
|
|
Dim As String wdSS
|
|
Dim As ULong i, m, ff = FreeFile
|
|
Dim ok As Boolean
|
|
|
|
Open "unixdict.txt" For Input As #ff
|
|
If Err > 0 Then
|
|
Print !"\n unixdict.txt not found, program will end"
|
|
Sleep 5000
|
|
End
|
|
End If
|
|
While Eof(1) = 0
|
|
Input #ff, wdSS
|
|
If Len(wdSS) > 2 And Len(wdSS) < 11 Then
|
|
ok = TRUE
|
|
For m = 1 To Len(wdSS)
|
|
If Asc(wdSS, m) < 97 Or Asc(wdSS, m) > 122 Then ok = FALSE: Exit For
|
|
Next
|
|
If ok Then i += 1: WORDSSS(i) = wdSS: CWORDSSS(i) = wdSS
|
|
End If
|
|
Wend
|
|
Close #ff
|
|
NWORDS = i
|
|
End Sub
|
|
|
|
Sub Shuffle
|
|
Dim As ULong i, r
|
|
For i = NWORDS To 2 Step -1
|
|
r = Int(Rnd * i) + 1
|
|
Swap WORDSSS(i), WORDSSS(r)
|
|
Next
|
|
End Sub
|
|
|
|
Sub Initialize
|
|
Dim As ULong r, c'', x, y, d
|
|
Dim As String wdSS
|
|
|
|
FILLED = FALSE
|
|
For r = 0 To 9
|
|
For c = 0 To 9
|
|
LSS(c, r) = " "
|
|
Next
|
|
Next
|
|
|
|
'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 Long, y As Long, d As Long)
|
|
|
|
For i As ULong = 0 To Len(wdSS) - 1
|
|
LSS(x + i * DX(d), y + i * DY(d)) = Mid(wdSS, i + 1, 1)
|
|
Next
|
|
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 ULong
|
|
Dim As ULong x, y, count
|
|
|
|
For y = 0 To 9
|
|
For x = 0 To 9
|
|
If LSS(x, y) = " " Then count += 1
|
|
Next
|
|
Next
|
|
CountSpaces = count
|
|
End Function
|
|
|
|
Sub ShowPuzzle
|
|
Dim As ULong 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
|
|
For y = 0 To 9
|
|
For x = 0 To 9
|
|
Locate y + 3, 2 * x + 5: Print LSS(x, y)
|
|
Next
|
|
Next
|
|
For i = 1 To WI
|
|
If i < 21 Then
|
|
Locate i + 1, 30: Print TrmSS(i); " "; WSS(i)
|
|
ElseIf i < 41 Then
|
|
Locate i - 20 + 1, 45: Print TrmSS(i); " "; WSS(i)
|
|
ElseIf i < 61 Then
|
|
Locate i - 40 + 1, 60: Print TrmSS(i); " "; WSS(i)
|
|
End If
|
|
Next
|
|
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 Long
|
|
Dim i As ULong
|
|
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
|
|
Dim As Long rdir
|
|
Dim As ULong wLen, spot, testNum
|
|
Dim As ULong 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 = 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
|
|
ShowPuzzle
|
|
If CountSpaces = 0 Then FILLED = TRUE
|
|
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 ULong wLen, x, y, d, j
|
|
Dim As Boolean b1, b2
|
|
|
|
For i As ULong = 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
|
|
If templateSS = wdSS Then 'found a 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
|
|
End If
|
|
Next
|
|
Next
|
|
Next
|
|
End Sub
|
|
|
|
Sub FilePuzzle
|
|
Dim As ULong i, r, c, ff = FreeFile
|
|
Dim As String bSS
|
|
|
|
Open "WS Puzzle.txt" For Output As #ff
|
|
Print #ff, " 0 1 2 3 4 5 6 7 8 9"
|
|
Print #ff,
|
|
For r = 0 To 9
|
|
bSS = TrmSS(r) + " "
|
|
For c = 0 To 9
|
|
bSS += LSS(c, r) + " "
|
|
Next
|
|
Print #ff, bSS
|
|
Next
|
|
Print #ff,
|
|
Print #ff, "Directions >>>---> 0 = East, 1 = SE, 2 = South, 3 = SW, 4 = West, 5 = NW, 6 = North, 7 = NE"
|
|
Print #ff,
|
|
Print #ff, " These are the items from unixdict.txt used to build the puzzle:"
|
|
Print #ff,
|
|
For i = 1 To WI Step 2
|
|
Print #ff, 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 #ff, 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 #ff,
|
|
End If
|
|
Next
|
|
Print #ff,
|
|
Print #ff, " These are the items from unixdict.txt found embedded in the puzzle:"
|
|
Print #ff,
|
|
For i = 1 To ALLindex Step 2
|
|
Print #ff, 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 #ff, 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 #ff, ""
|
|
End If
|
|
Next
|
|
Print #ff,
|
|
Print #ff, "On try #" + TrmSS(try) + " a successful puzzle was built and filed."
|
|
Close #ff
|
|
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
|
|
If Not filled And WI > 24 Then ' we have 25 or more words
|
|
For y As ULong = 0 To 9 ' fill spaces with random letters
|
|
For x As ULong = 0 To 9
|
|
If LSS(x, y) = " " Then LSS(x, y) = Chr(Int(Rnd * 26) + 1 + 96)
|
|
Next
|
|
Next
|
|
filled = TRUE
|
|
ShowPuzzle
|
|
End If
|
|
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 Not FILLED Then Locate 23, 1: Print "Sorry, 10 tries and no success."
|
|
|
|
Sleep
|
|
End
|