VBA（目前平均水平为80-110点，未完成）
这是我的工作流程，但远非最佳。经过多次测试后，我在任何主板上发现的绝对最佳分数约为120。仍然需要进行更好的常规清理，并且我相信在许多地方都可以获得更高的效率。
- 2012.05.09：
- 2012.05.10-2012.05.18：
- 2012.06.07-2012.06.12：
- 字数限制从8个减少到6个。似乎平均得分略有提高。（每次运行检查10-15个左右的木板，而1到2个）
- 按照面包箱的建议，我创建了一个树形结构来容纳单词列表。这确实大大加快了板上单词的后端检查。
- 我在更改最大单词大小（速度与得分）时玩过，但我还不确定5或6对我来说是一个更好的选择。6个结果中有100-120个板子被检查，而5个结果中有500-1000个板子（两者都远低于到目前为止提供的其他示例）。
- 问题：经过多次连续运行后，该过程开始变慢，因此仍然需要管理一些内存。
对于您中的某些人来说，这可能看起来很可怕，但是正如我所说的，WIP。我非常乐意接受建设性的批评！很抱歉身材太长了...
骰子类模块：
Option Explicit
Private Sides() As String
Sub NewDie(NewLetters As String)
Sides = Split(NewLetters, ",")
End Sub
Property Get Side(i As Integer)
Side = Sides(i)
End Property
树类模块：
Option Explicit
Private zzroot As TreeNode
Sub AddtoTree(ByVal TreeWord As Variant)
Dim i As Integer
Dim TempNode As TreeNode
Set TempNode = TraverseTree(TreeWord, zzroot)
SetNode TreeWord, TempNode
End Sub
Private Function SetNode(ByVal Value As Variant, parent As TreeNode) As TreeNode
Dim ValChar As String
If Len(Value) > 0 Then
ValChar = Left(Value, 1)
Select Case Asc(ValChar) - 96
Case 1:
Set parent.Node01 = AddNode(ValChar, parent.Node01)
Set SetNode = parent.Node01
Case 2:
Set parent.Node02 = AddNode(ValChar, parent.Node02)
Set SetNode = parent.Node02
' ... - Reduced to limit size of answer.
Case 26:
Set parent.Node26 = AddNode(ValChar, parent.Node26)
Set SetNode = parent.Node26
Case Else:
Set SetNode = Nothing
End Select
Set SetNode = SetNode(Right(Value, Len(Value) - 1), SetNode)
Else
Set parent.Node27 = AddNode(True, parent.Node27)
Set SetNode = parent.Node27
End If
End Function
Function AddNode(ByVal Value As Variant, NewNode As TreeNode) As TreeNode
If NewNode Is Nothing Then
Set AddNode = New TreeNode
AddNode.Value = Value
Else
Set AddNode = NewNode
End If
End Function
Function TraverseTree(TreeWord As Variant, parent As TreeNode) As TreeNode
Dim Node As TreeNode
Dim ValChar As String
If Len(TreeWord) > 0 Then
ValChar = Left(TreeWord, 1)
Select Case Asc(ValChar) - 96
Case 1:
Set Node = parent.Node01
Case 2:
Set Node = parent.Node02
' ... - Reduced to limit size of answer.
Case 26:
Set Node = parent.Node26
Case Else:
Set Node = Nothing
End Select
If Not Node Is Nothing Then
Set TraverseTree = TraverseTree(Right(TreeWord, Len(TreeWord) - 1), Node)
If Not TraverseTree Is Nothing Then
Set TraverseTree = parent
End If
Else
Set TraverseTree = parent
End If
Else
If parent.Node27.Value Then
Set TraverseTree = parent
Else
Set TraverseTree = Nothing
End If
End If
End Function
Function WordScore(TreeWord As Variant, Step As Integer, Optional parent As TreeNode = Nothing) As Integer
Dim Node As TreeNode
Dim ValChar As String
If parent Is Nothing Then Set parent = zzroot
If Len(TreeWord) > 0 Then
ValChar = Left(TreeWord, 1)
Select Case Asc(ValChar) - 96
Case 1:
Set Node = parent.Node01
Case 2:
Set Node = parent.Node02
' ... - Reduced to limit size of answer.
Case 26:
Set Node = parent.Node26
Case Else:
Set Node = Nothing
End Select
If Not Node Is Nothing Then
WordScore = WordScore(Right(TreeWord, Len(TreeWord) - 1), Step + 1, Node)
End If
Else
If parent.Node27 Is Nothing Then
WordScore = 0
Else
WordScore = Step
End If
End If
End Function
Function ValidWord(TreeWord As Variant, Optional parent As TreeNode = Nothing) As Integer
Dim Node As TreeNode
Dim ValChar As String
If parent Is Nothing Then Set parent = zzroot
If Len(TreeWord) > 0 Then
ValChar = Left(TreeWord, 1)
Select Case Asc(ValChar) - 96
Case 1:
Set Node = parent.Node01
Case 2:
Set Node = parent.Node02
' ... - Reduced to limit size of answer.
Case 26:
Set Node = parent.Node26
Case Else:
Set Node = Nothing
End Select
If Not Node Is Nothing Then
ValidWord = ValidWord(Right(TreeWord, Len(TreeWord) - 1), Node)
Else
ValidWord = False
End If
Else
If parent.Node27 Is Nothing Then
ValidWord = False
Else
ValidWord = True
End If
End If
End Function
Private Sub Class_Initialize()
Set zzroot = New TreeNode
End Sub
Private Sub Class_Terminate()
Set zzroot = Nothing
End Sub
TreeNode类模块：
Option Explicit
Public Value As Variant
Public Node01 As TreeNode
Public Node02 As TreeNode
' ... - Reduced to limit size of answer.
Public Node26 As TreeNode
Public Node27 As TreeNode
主模块：
Option Explicit
Const conAllSides As String = ";a,a,e,e,g,n;e,l,r,t,t,y;a,o,o,t,t,w;a,b,b,j,o,o;e,h,r,t,v,w;c,i,m,o,t,u;d,i,s,t,t,y;e,i,o,s,s,t;d,e,l,r,v,y;a,c,h,o,p,s;h,i,m,n,qu,u;e,e,i,n,s,u;e,e,g,h,n,w;a,f,f,k,p,s;h,l,n,n,r,z;d,e,i,l,r,x;"
Dim strBoard As String, strBoardTemp As String, strWords As String, strWordsTemp As String
Dim CheckWordSub As String
Dim iScore As Integer, iScoreTemp As Integer
Dim Board(1 To 4, 1 To 4) As Integer
Dim AllDice(1 To 16) As Dice
Dim AllWordsTree As Tree
Dim AllWords As Scripting.Dictionary
Dim CurWords As Scripting.Dictionary
Dim FullWords As Scripting.Dictionary
Dim JunkWords As Scripting.Dictionary
Dim WordPrefixes As Scripting.Dictionary
Dim StartTime As Date, StopTime As Date
Const MAX_LENGTH As Integer = 5
Dim Points(3 To 8) As Integer
Sub Boggle()
Dim DiceSetup() As String
Dim i As Integer, j As Integer, k As Integer
StartTime = Now()
strBoard = vbNullString
strWords = vbNullString
iScore = 0
ReadWordsFileTree
DiceSetup = Split(conAllSides, ";")
For i = 1 To 16
Set AllDice(i) = New Dice
AllDice(i).NewDie "," & DiceSetup(i)
Next i
Do While WithinTimeLimit
Shuffle
strBoardTemp = vbNullString
strWordsTemp = vbNullString
iScoreTemp = 0
FindWords
If iScoreTemp > iScore Or iScore = 0 Then
iScore = iScoreTemp
k = 1
For i = 1 To 4
For j = 1 To 4
strBoardTemp = strBoardTemp & AllDice(k).Side(Board(j, i)) & " "
k = k + 1
Next j
strBoardTemp = strBoardTemp & vbNewLine
Next i
strBoard = strBoardTemp
strWords = strWordsTemp
End If
Loop
Debug.Print strBoard
Debug.Print strWords
Debug.Print iScore & " points"
Set AllWordsTree = Nothing
Set AllWords = Nothing
Set CurWords = Nothing
Set FullWords = Nothing
Set JunkWords = Nothing
Set WordPrefixes = Nothing
End Sub
Sub ShuffleBoard()
Dim i As Integer
For i = 1 To 16
If Not WithinTimeLimit Then Exit Sub
Board(Int((i - 1) / 4) + 1, 4 - (i Mod 4)) = Int(6 * Rnd() + 1)
Next i
End Sub
Sub Shuffle()
Dim n As Long
Dim Temp As Variant
Dim j As Long
Randomize
ShuffleBoard
For n = 1 To 16
If Not WithinTimeLimit Then Exit Sub
j = CLng(((16 - n) * Rnd) + n)
If n <> j Then
Set Temp = AllDice(n)
Set AllDice(n) = AllDice(j)
Set AllDice(j) = Temp
End If
Next n
Set FullWords = New Scripting.Dictionary
Set CurWords = New Scripting.Dictionary
Set JunkWords = New Scripting.Dictionary
End Sub
Sub ReadWordsFileTree()
Dim FSO As New FileSystemObject
Dim FS
Dim strTemp As Variant
Dim iLength As Integer
Dim StartTime As Date
StartTime = Now()
Set AllWordsTree = New Tree
Set FS = FSO.OpenTextFile("P:\Personal\english.txt")
Points(3) = 1
Points(4) = 1
Points(5) = 2
Points(6) = 3
Points(7) = 5
Points(8) = 11
Do Until FS.AtEndOfStream
strTemp = FS.ReadLine
If strTemp = LCase(strTemp) Then
iLength = Len(strTemp)
iLength = IIf(iLength > 8, 8, iLength)
If InStr(strTemp, "'") < 1 And iLength > 2 Then
AllWordsTree.AddtoTree strTemp
End If
End If
Loop
FS.Close
End Sub
Function GetScoreTree() As Integer
Dim TempScore As Integer
If Not WithinTimeLimit Then Exit Function
GetScoreTree = 0
TempScore = AllWordsTree.WordScore(CheckWordSub, 0)
Select Case TempScore
Case Is < 3:
GetScoreTree = 0
Case Is > 8:
GetScoreTree = 11
Case Else:
GetScoreTree = Points(TempScore)
End Select
End Function
Sub SubWords(CheckWord As String)
Dim CheckWordScore As Integer
Dim k As Integer, l As Integer
For l = 0 To Len(CheckWord) - 3
For k = 1 To Len(CheckWord) - l
If Not WithinTimeLimit Then Exit Sub
CheckWordSub = Mid(CheckWord, k, Len(CheckWord) - ((k + l) - 1))
If Len(CheckWordSub) >= 3 And Not CurWords.Exists(CheckWordSub) Then
CheckWordScore = GetScoreTree
If CheckWordScore > 0 Then
CurWords.Add CheckWordSub, CheckWordSub
iScoreTemp = iScoreTemp + CheckWordScore
strWordsTemp = strWordsTemp & CheckWordSub & vbNewLine
End If
If Left(CheckWordSub, 1) = "q" Then
k = k + 1
End If
End If
Next k
Next l
End Sub
Sub FindWords()
Dim CheckWord As String
Dim strBoardLine(1 To 16) As String
Dim Used(1 To 16) As Boolean
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer
Dim StartSquare As Integer
Dim FullCheck As Variant
n = 1
For l = 1 To 4
For m = 1 To 4
If Not WithinTimeLimit Then Exit Sub
strBoardLine(n) = AllDice(n).Side(Board(m, l))
n = n + 1
Next m
Next l
For i = 1 To 16
For k = 1 To 16
If Not WithinTimeLimit Then Exit Sub
If k Mod 2 = 0 Then
For j = 1 To 16
Used(j) = False
Next j
Used(i) = True
MakeWords strBoardLine, Used, i, k / 2, strBoardLine(i)
End If
Next k
Next i
For Each FullCheck In FullWords.Items
SubWords CStr(FullCheck)
Next FullCheck
End Sub
Function MakeWords(BoardLine() As String, Used() As Boolean, _
Start As Integer, _
Direction As Integer, CurString As String) As String
Dim i As Integer, j As Integer, k As Integer, l As Integer
j = 0
Select Case Direction
Case 1:
k = Start - 5
Case 2:
k = Start - 4
Case 3:
k = Start - 3
Case 4:
k = Start - 1
Case 5:
k = Start + 1
Case 6:
k = Start + 3
Case 7:
k = Start + 4
Case 8:
k = Start + 5
End Select
If k >= 1 And k <= 16 Then
If Not WithinTimeLimit Then Exit Function
If Not Used(k) Then
If ValidSquare(Start, k) Then
If Not (JunkWords.Exists(CurString & BoardLine(k))) And Not FullWords.Exists(CurString & BoardLine(k)) Then
Used(k) = True
For l = 1 To MAX_LENGTH
If Not WithinTimeLimit Then Exit Function
MakeWords = CurString & BoardLine(k)
If Not (JunkWords.Exists(MakeWords)) Then
JunkWords.Add MakeWords, MakeWords
End If
If Len(MakeWords) = MAX_LENGTH And Not FullWords.Exists(MakeWords) Then
FullWords.Add MakeWords, MakeWords
ElseIf Len(MakeWords) < MAX_LENGTH Then
MakeWords BoardLine, Used, k, l, MakeWords
End If
Next l
Used(k) = False
End If
End If
End If
End If
If Len(MakeWords) = MAX_LENGTH And Not FullWords.Exists(MakeWords) Then
FullWords.Add MakeWords, MakeWords
Debug.Print "FULL - " & MakeWords
End If
End Function
Function ValidSquare(StartSquare As Integer, EndSquare As Integer) As Boolean
Dim sx As Integer, sy As Integer, ex As Integer, ey As Integer
If Not WithinTimeLimit Then Exit Function
sx = (StartSquare - 1) Mod 4 + 1
ex = (EndSquare - 1) Mod 4 + 1
sy = Int((StartSquare - 1) / 4 + 1)
ey = Int((EndSquare - 1) / 4 + 1)
ValidSquare = (sx - 1 <= ex And sx + 1 >= ex) And (sy - 1 <= ey And sy + 1 >= ey) And StartSquare <> EndSquare
End Function
Function WithinTimeLimit() As Boolean
StopTime = Now()
WithinTimeLimit = (Round(CDbl(((StopTime - StartTime) - Int(StopTime - StartTime)) * 86400), 0) < 120)
End Function
4527（1414总单词数），可在以下位置