VBA (현재 80-110 포인트 범위, 미완성)
여기 내 작업 과정이 있지만 가능한 한 멀리 떨어져 있습니다. 많은 테스트 실행 후 모든 보드에서 찾은 내 절대 최고 점수는 약 120입니다. 여전히 더 나은 일반적인 정리가 필요하며 여러 곳에서 더 많은 효율성을 얻을 것이라고 확신합니다.
- 2012.05.09 :
- 2012.05.10-2012.05.18 :
- 2012.06.07-2012.06.12 :
- 단어 제한을 8에서 6으로 줄였습니다. 더 작은 단어로 더 많은 보드를 허용합니다. 평균 점수가 약간 개선 된 것으로 보입니다. (1 ~ 2에 대한 런당 10-15 정도의 보드 확인)
- 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
트리 클래스 모듈 :
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