VBA (ปัจจุบันเฉลี่ยอยู่ระหว่าง 80-110 จุดยังไม่เสร็จ)
นี่คือกระบวนการทำงานของฉัน แต่มันไกลเกินกว่าที่จะเป็นไปได้ คะแนนที่ดีที่สุดของฉันที่พบในกระดานใด ๆ หลังจากการทดสอบจำนวนมากอยู่ที่ประมาณ 120. ยังคงต้องมีการทำความสะอาดทั่วไปที่ดีขึ้นและฉันแน่ใจว่ามีประสิทธิภาพมากขึ้นที่จะได้รับในหลายสถานที่
- 2012/05/09:
- 2012.05.10 - 2012.05.18:
- ปรับปรุงอัลกอริทึมการให้คะแนน
- ปรับปรุงตรรกะการค้นหาเส้นทาง
- 2012.06.07 - 2012.06.12 :
- จำกัด จำนวนคำที่ลดลงเหลือ 6 จาก 8 อนุญาตให้บอร์ดเพิ่มเติมที่มีคำน้อยกว่า ดูเหมือนว่าจะมีการปรับปรุงคะแนนเฉลี่ยเล็กน้อย (บอร์ด 10-15 หรือมากกว่านั้นได้รับการตรวจสอบต่อการวิ่งเทียบกับ 1 ถึง 2)
- ตามคำแนะนำของ breadbox ฉันได้สร้างโครงสร้างต้นไม้เพื่อใช้เป็นที่เก็บคำศัพท์ นี่เป็นการเพิ่มความเร็วในการตรวจสอบคำท้ายกระดานอย่างรวดเร็ว
- ฉันเล่นกับการเปลี่ยนขนาดคำสูงสุด (ความเร็วเทียบกับคะแนน) และฉันยังไม่ได้ตัดสินใจว่า 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
Tree Class Module :
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/~chuongdo/boggle/index.html