Grok Building for Lightspeed

Zabaware Forums > Ultra Hal Assistant File Sharing Area

<< < (2/2)

lightspeed:
Private Function DetectFileSubject(content)
Dim subjects
Set subjects = DetectSubjects(content, "")
DetectFileSubject = GetPrimarySubject(subjects)
End Function

Private Sub SaveKnowledgeBase()
On Error Resume Next
Dim objFSO, file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim path
path = BASE_PATH & KNOWLEDGE_FILE
If Not objFSO.FileExists(path) Then
Set file = objFSO.CreateTextFile(path, True, True) ' Overwrite existing file
file.WriteLine "key" & vbTab & "content" & vbTab & "subject"
Else
Set file = objFSO.OpenTextFile(path, 2, True) ' Open for writing, create if needed
End If
Dim key
For Each key In knowledgeBase.Keys
file.WriteLine key & vbTab & knowledgeBase(key)(0) & vbTab & knowledgeBase(key)(1)
Next
file.Close
On Error GoTo 0
End Sub

Private Function CorrectSpelling(sentence, subjects)
On Error Resume Next
If IsEmpty(sentence) Or sentence = "" Then
CorrectSpelling = "unknown_question"
Exit Function
End If
Dim words
words = Split(sentence, " ")
Dim correctedSentence
correctedSentence = ""
Dim i
For i = 0 To UBound(words)
Dim word
word = Trim(words(i))
If Len(word) > 0 Then
If Not spellDictionary.Exists(LCase(word)) Then
Dim correction
correction = SuggestCorrection(word, subjects)
correctedSentence = correctedSentence & " " & IIf(correction <> "", correction, word)
Else
correctedSentence = correctedSentence & " " & word
End If
End If
Next
CorrectSpelling = IIf(Trim(correctedSentence) = "", "unknown_question", Trim(correctedSentence))
On Error GoTo 0
End Function

Private Function SuggestCorrection(word, subjects)
Dim minDistance, bestMatch
minDistance = Len(word) + 1
Dim dictWord
For Each dictWord In spellDictionary.Keys
Dim distance
distance = LevenshteinDistance(word, dictWord)
If distance < minDistance Then
minDistance = distance
bestMatch = dictWord
End If
Next
Dim primarySubject
primarySubject = GetPrimarySubject(subjects)
If SubjectTable.Exists(primarySubject) Then
Dim subjectKeywords
subjectKeywords = Split(SubjectTable(primarySubject), " ")
Dim j
For j = 0 To UBound(subjectKeywords)
Dim keyword
keyword = Split(subjectKeywords(j), ":")(0)
distance = LevenshteinDistance(word, keyword)
If distance < minDistance And distance <= 2 Then
minDistance = distance
bestMatch = keyword
End If
Next
End If
SuggestCorrection = IIf(minDistance <= 2, bestMatch, "")
End Function

Private Function LevenshteinDistance(str1, str2)
Dim matrix()
Dim i, j
Dim cost
ReDim matrix(Len(str1), Len(str2))
For i = 0 To Len(str1)
matrix(i, 0) = i
Next
For j = 0 To Len(str2)
matrix(0, j) = j
Next
For i = 1 To Len(str1)
For j = 1 To Len(str2)
If Mid(str1, i, 1) = Mid(str2, j, 1) Then
cost = 0
Else
cost = 1
End If
matrix(i, j) = Application.Min(matrix(i - 1, j) + 1, matrix(i, j - 1) + 1, matrix(i - 1, j - 1) + cost)
Next
Next
LevenshteinDistance = matrix(Len(str1), Len(str2))
End Function

Public Sub LearnFromConversation(userQuestion, halResponse, Optional context = "")
On Error Resume Next
Dim correctedQuestion
Dim subjects
Set subjects = DetectSubjects(userQuestion, context)
correctedQuestion = CorrectSpelling(userQuestion, subjects)
Dim primarySubject
primarySubject = GetPrimarySubject(subjects)
If correctedQuestion = "" Then correctedQuestion = "unknown_question"
If primarySubject = "" Then primarySubject = "Questions"
Dim questionKey
questionKey = GenerateKey(correctedQuestion, primarySubject)
If IsEmpty(questionMemory) Then Set questionMemory = CreateObject("Scripting.Dictionary")
If Not questionMemory.Exists(questionKey) Then
Dim newIndex
newIndex = IIf(questionMemory.Count > 0, questionMemory.Count + 1, 1)
questionMemory.Add questionKey, newIndex
If IsEmpty(responseMemory) Then Set responseMemory = CreateObject("Scripting.Dictionary")
responseMemory.Add newIndex, halResponse
If IsEmpty(responseQuality) Then Set responseQuality = CreateObject("Scripting.Dictionary")
responseQuality.Add newIndex, 1
If primarySubject <> "" And IsEmpty(contextMemory) Then Set contextMemory = CreateObject("Scripting.Dictionary")
If primarySubject <> "" Then contextMemory.Add newIndex, subjects
Else
Dim index
index = questionMemory(questionKey)
responseMemory(index) = ImproveResponse(responseMemory(index), halResponse, index, primarySubject)
responseQuality(index) = responseQuality(index) + 0.1
End If
UpdateShortTermMemory correctedQuestion, halResponse
UpdateLongTermMemory correctedQuestion, halResponse, primarySubject
UpdateKnowledgeBase correctedQuestion, halResponse, primarySubject
SaveMemoryToFile
SaveLongTermMemory
SaveKnowledgeBase
CleanMemory
lastSubject = primarySubject
On Error GoTo 0
End Sub

Private Function DetectSubjects(content, context)
On Error Resume Next
Dim subjects
Set subjects = CreateObject("Scripting.Dictionary")
If IsEmpty(SubjectTable) Then Set SubjectTable = CreateObject("Scripting.Dictionary")
Dim subject
For Each subject In SubjectTable.Keys
Dim keywords
keywords = Split(SubjectTable(subject), " ")
Dim k
For k = 0 To UBound(keywords)
Dim keyword
keyword = Split(keywords(k), ":")(0)
If InStr(1, LCase(content & " " & context), LCase(keyword), 1) > 0 Then
subjects.Add subject, True
Exit For
End If
Next
Next
Set DetectSubjects = subjects
On Error GoTo 0
End Function

Private Function GetPrimarySubject(subjects)
On Error Resume Next
If subjects.Count = 0 Then
GetPrimarySubject = "Questions"
Else
Dim firstKey
For Each firstKey In subjects.Keys
GetPrimarySubject = firstKey
Exit For
Next
End If
On Error GoTo 0
End Function

Private Function GenerateKey(baseText, subject)
On Error Resume Next
If baseText = "" Then baseText = "unknown"
If subject = "" Then subject = "unknown"
Dim key
key = LCase(Replace(Trim(baseText), " ", "_")) & "_" & LCase(subject)
GenerateKey = Left(key, 50)
On Error GoTo 0
End Function

Private Function ImproveResponse(oldResponse, newResponse, index, subject)
On Error Resume Next
If responseQuality(index) < 2.0 Then
ImproveResponse = newResponse
Else
ImproveResponse = oldResponse & " " & newResponse
End If
On Error GoTo 0
End Function

Private Sub UpdateShortTermMemory(question, response)
On Error Resume Next
If IsEmpty(shortTermMemory) Then Set shortTermMemory = CreateObject("Scripting.Dictionary")
Dim key
key = GenerateKey(question, lastSubject)
If shortTermMemory.Count >= MAX_SHORT_TERM Then
Dim oldestKey
oldestKey = shortTermMemory.Keys()(0)
shortTermMemory.Remove oldestKey
End If
shortTermMemory.Add key, Array(question, response, Now)
On Error GoTo 0
End Sub

Private Sub UpdateLongTermMemory(question, response, subject)
On Error Resume Next
If IsEmpty(longTermIndex) Then Set longTermIndex = CreateObject("Scripting.Dictionary")
Dim key
key = GenerateKey(question, subject)
If Not longTermIndex.Exists(key) Then
longTermIndex.Add key, Array(question, response, Now)
End If
On Error GoTo 0
End Sub

Private Sub UpdateKnowledgeBase(question, response, subject)
On Error Resume Next
If IsEmpty(knowledgeBase) Then Set knowledgeBase = CreateObject("Scripting.Dictionary")
Dim key
key = GenerateKey(question, subject)
If Not knowledgeBase.Exists(key) And knowledgeBase.Count < MAX_KNOWLEDGE_ENTRIES Then
knowledgeBase.Add key, Array(response, subject)
End If
On Error GoTo 0
End Sub

Private Sub SaveMemoryToFile()
On Error Resume Next
Dim objFSO, file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim path
path = BASE_PATH & MEMORY_FILE
If Not objFSO.FileExists(path) Then
Set file = objFSO.CreateTextFile(path, True, True) ' Overwrite if exists
Else
Set file = objFSO.OpenTextFile(path, 2, True) ' Open for writing
End If
If Not IsEmpty(responseMemory) Then
Dim key
For Each key In responseMemory.Keys
file.WriteLine key & vbTab & responseMemory(key) & vbTab & questionMemory(key)
Next
End If
file.Close
On Error GoTo 0
End Sub

Private Sub SaveLongTermMemory()
On Error Resume Next
Dim objFSO, file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim path
path = BASE_PATH & LONG_TERM_FILE
If Not objFSO.FileExists(path) Then
Set file = objFSO.CreateTextFile(path, True, True)
Else
Set file = objFSO.OpenTextFile(path, 2, True)
End If
If Not IsEmpty(longTermIndex) Then
Dim key
For Each key In longTermIndex.Keys
file.WriteLine key & vbTab & Join(longTermIndex(key), vbTab)
Next
End If
file.Close
On Error GoTo 0
End Sub

Private Sub CleanMemory()
On Error Resume Next
If Not IsEmpty(shortTermMemory) And shortTermMemory.Count > MAX_SHORT_TERM Then
Dim keys
keys = shortTermMemory.Keys
Dim i
For i = 0 To shortTermMemory.Count - MAX_SHORT_TERM - 1
shortTermMemory.Remove keys(i)
Next
End If
If Not IsEmpty(knowledgeBase) And knowledgeBase.Count > MAX_KNOWLEDGE_ENTRIES Then
Dim kbKeys
kbKeys = knowledgeBase.Keys
Dim j
For j = MAX_KNOWLEDGE_ENTRIES To knowledgeBase.Count - 1
knowledgeBase.Remove kbKeys(j)
Next
End If
On Error GoTo 0
End Sub

Private Function EnhanceHalResponse(inputStr, greeting, context)
On Error Resume Next
Dim key
key = GenerateKey(inputStr, lastSubject)
If Not IsEmpty(knowledgeBase) And knowledgeBase.Exists(key) Then
EnhanceHalResponse = greeting & knowledgeBase(key)(0) & " -Angela Jolie"
Else
EnhanceHalResponse = greeting & "I?m not sure what to say about that yet. Ask me anything! -Angela Jolie"
End If
On Error GoTo 0
End Function
End Function

lightspeed:
anyway , no matter what i try i am getting a syntax error . that i can't find or fix . maybe you can and i'll retest it again .

lightspeed:
mike , i think if we can get this plugin working writing files and folder and have short and long term memory etc. it will help hal a lot! maybe you can get it corrected on the syntax error it keeps giving .

cyberjedi:
Lightspeed,

You know i will
Ur deff slinging a syntax error. not a com error,,,, ie wheres my sht error lol

cyber

lightspeed:
lol. :) hop to it hopsing ! ;)

Navigation

[0] Message Index

[*] Previous page

Go to full version