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合計単語数）です。ai.stanford.edu