之前寫的，本來打算寫成開源類庫的，可是用C#移植的時候發現了很大的問題，主要是當機器人回答時執行效率太慢，而我又沒有什么好的改進方法，所以我決定將此程序代碼全部公開，完整代碼下載請前往：

VB.NET版：http://download.csdn.net/detail/qinyuanpei/5561585

C#移植版（未完成）：http://download.csdn.net/detail/qinyuanpei/5561619

?

Imports System Imports System.Xml Imports Lucene.Net.Analysis Imports System.Text Imports System.Net Imports System.IOPublic Class chatPublic XmlPath As String '語料數據路徑Public username As String '使用者名字Public robotname As String '機器人名字Dim myvoice As Object '創建語音選項Dim systime As StringDim a As StringDim q As String' Public WithEvents RC As New SpeechLib.SpSharedRecoContextDim lastq As String '用于記錄上一個問題Dim besta As String '用于記錄學習后的答案Dim lasta As String '用于判斷上一個問題的答案Dim CmdList As New ArrayList '加載預定義命令列表Public IsTalkWithSound As Boolean '用于判斷是否啟用語音朗讀的變量Public IsSoundRecognition As Boolean '用于判斷是否啟用語音識別的變量Public IsMsgWithSound As Boolean '用于判斷是否開啟消息提示音Dim Point As Point '用于窗體的移動'對話過程CmdtalkPrivate Sub Cmdtalk_Click() Handles Cmdtalk.Clickq = txtq.Textsystime = DateTime.Now.Hour & ":" & DateTime.Now.Minute & ":" & DateTime.Now.Secondtxtans.Text = txtans.Text & vbNewLine & vbNewLine & systime & Space(2) & "【" & username & "】" & "說:" & vbNewLine & qPlayMusic()a = Response(q)'開始匹配答案 核心部分txtans.Text = txtans.Text & vbNewLine & vbNewLine & systime & Space(2) & "【" & robotname & "】" & "說:" & vbNewLine & atxtans.SelectionStart = Len(txtans.Text & vbNewLine & vbNewLine) '選擇文本插入點，給下面的文字空出空間txtans.ScrollToCaret() '滾動條滾動開始'自動學習開始()lastq = q '記錄前一個問題的內容lasta = a '記錄前一個問題的答案If XpathToXml(lastq) = 0 And lasta <> "莉莉不知道怎樣回答" ThenAddNewKnowledge(lastq, lasta)End Iftxtq.Text = ""End Sub'頁面初始化主函數Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.LoadRandomize()LoadCmd() '加載命令列表IsTalkWithSound = FalseIsSoundRecognition = Falseusername = "我"robotname = "莉莉"systime = DateTime.Now.Hour & ":" & DateTime.Now.Minute & ":" & DateTime.Now.Secondtxtans.Text = txtans.Text & systime & Space(2) & "【" & robotname & "】" & "說:" & vbNewLine & "朋友，你好，我是基于Alice的智能聊天機器人，我叫莉莉"txtans.Select(Len(txtans.Text), 0)'TalkWithSound(username & "，你好，我是基于Alice的智能聊天機器人，我叫莉莉,我可以為您做些什么呢？")'SoundRecognition()End Sub'加載預置命令Private Sub LoadCmd()Dim xmldoc As New XmlDocumentxmldoc.Load(Application.StartupPath & "\aiml\cmd.xml")Dim nodeList As XmlNodeListDim root As XmlElement = xmldoc.DocumentElementnodeList = root.SelectNodes("/cmdlist/cmd")Dim a As String = ""Dim node As XmlNode = NothingFor Each node In nodeListCmdList.Add(node.InnerText)NextEnd Sub'分詞模塊，比較簡單，沒想到中科院的效果那么差Public Function SplitWords(ByVal input As String) As StringDim sb As New StringBuilder()sb.Remove(0, sb.Length)Dim t1 As String = ""Dim i As Integer = 0Dim analyzer = New Lucene.Net.Analysis.China.ChineseAnalyzerDim sr As New StringReader(input)Dim stream As TokenStreamstream = analyzer.TokenStream("", sr)Dim t As Token = stream.Next()While t Is Nothing = Falset1 = t.ToString()t1 = t1.Replace("(", "")sb.Append(i & ":" & "(" & t1)t = stream.Next()i += 1End WhileSplitWords = sb.ToString()End Function'機器人反應函數ResponsePublic Function Response(ByVal str As String) As String'這里指定所有的命令函數格式為：“函數名：參數一|參數二|參數三.....”Response = ""If InStr(str, "：") > 0 ThenDim CmdStr As String = str.Substring(0, str.IndexOf("："))Dim OptionStr As String = str.Substring(str.IndexOf("：") + 1, str.Length - str.IndexOf("：") - 1)If CmdList.Contains(CmdStr) Then '先處理特殊的命令字符, 然后處理一般的會話，處理前需要判斷是否存在命令標志"："Select Case CmdStrCase "天氣"Response = Plugin_Weather(OptionStr)Case "搜索"Response = Plugin_Search(OptionStr)Case "翻譯"Response = Plugin_Translate(OptionStr)Case "地圖"Response = PlugIn_Map()Case "百科"Response = Plugin_Baike()Case "數學"Response = Plugin_Math(OptionStr)End SelectEnd IfElseIf XpathToXml(str) > 0 Then '在本地查找滿足模糊條件的數據Response = GetLocalData(XpathToXml(str) - 1)ElseResponse = getWebData(str)End IfEnd IfReturn ResponseEnd Function'-----------------------------------------------------'-----------------------------------------------------'---------- 這里是用于擴展程序功能的插件--------------'-----------------------------------------------------'-----------------------------------------------------Function Plugin_Translate(ByVal q As String) As StringDim translate As New youdaoTranslateReturn translate.DoTranslate(q)End FunctionFunction Plugin_Weather(ByVal city As String) As StringReturn NothingEnd FunctionFunction Plugin_Search(ByVal keywords As String) As Stringbrowser.Show()browser.WebBrowser1.Navigate("http://www.baidu.com/s?wd=" + keywords)Return "莉莉已經完成對" + "[" + keywords + "]" + "的搜索"End FunctionFunction Plugin_Math(ByVal expression As String) As StringDim ScriptClass As New MSScriptControl.ScriptControlScriptClass.Language = "javascript"Dim obj As Object = ScriptClass.Eval(expression)Return expression + "=" + obj.ToString()End FunctionFunction PlugIn_Map()Return ""End FunctionFunction Plugin_Baike()Return ""End Function'-----------------------------------------------------'-----------------------------------------------------'---------------插件部分的代碼到此結束----------------'-----------------------------------------------------'-----------------------------------------------------'-----------------------------------------------------'-----------------------------------------------------'---------這里是用于從網絡獲取聊天數據的程序----------'-----------------------------------------------------'-----------------------------------------------------'從網絡上獲取數據Function getWebData(ByVal str As String) As StringDim webbot As New SimsimiDim cookie As String = webbot.getcookie()If webbot.showmsg(str, cookie) = "{}" ThenReturn "莉莉累了，休息一會兒....."ElseReturn webbot.showmsg(str, cookie)End IfEnd Function'-----------------------------------------------------'-----------------------------------------------------'-----------------------結束--------------------------'-----------------------------------------------------'-----------------------------------------------------'-----------------------------------------------------'-----------------------------------------------------'-------------------本地數據搜索模塊------------------'-----------------------------------------------------'-----------------------------------------------------'基于Xpath的模糊匹配,返回滿足要求的數據-問題索引Public Function XpathToXml(ByVal str As String) As IntegerDim IndexList As New ArrayList '用于保存滿足匹配條件的索引列表Dim pos As IntegerDim i As Integer = 0Dim xmldoc1 As New XmlDocumentxmldoc1.Load(Application.StartupPath & "\aiml\aiml.xml")Dim nodeList As XmlNodeListDim root As XmlElement = xmldoc1.DocumentElementnodeList = root.SelectNodes("/aiml/talk/question")Dim node As XmlNode = NothingFor Each node In nodeListDim q As String = node.InnerTexti = i + 1If str = q Or InStr(SplitWords(str), q) > 0 Then '如果滿足條件就保存當前索引到IndexListIndexList.Add(i)End IfNextIf IndexList.Count = 0 Then '假如列表中沒有符合要求的索引pos = 0Elsepos = IndexList(Int(Rnd() * (IndexList.Count))) '否則返回索引列表中的隨機索引值，加1是為了了避免出現1的錯誤，這樣會導致回答索引為0If pos = 1 Then pos = pos + 1 '避免因為隨機數而導致的出現答案索引為0的情形End IfReturn posEnd Function'獲取本地指定索引的數據-答案Public Function GetLocalData(ByVal index As Integer) As StringDim pos As Integer = 0Dim xmldoc1 As New XmlDocumentxmldoc1.Load(Application.StartupPath & "\aiml\aiml.xml")Dim nodeList As XmlNodeListDim root As XmlElement = xmldoc1.DocumentElementnodeList = root.SelectNodes("/aiml/talk/answer")Dim a As String = ""Dim node As XmlNode = NothingFor Each node In nodeLista = node.InnerTextpos = pos + 1If pos > index ThenExit ForEnd IfNextReturn aEnd Function'-----------------------------------------------------'-----------------------------------------------------'---------------本地數據搜索模塊結束------------------'-----------------------------------------------------'-----------------------------------------------------'*****************************************************'-----------------------------------------------------'-----------------------------------------------------'---------------機器學習部分函數模塊------------------'-----------------------------------------------------'-----------------------------------------------------'添加新知識到xml存檔Public Function AddNewKnowledge(ByVal q As String, ByVal a As String)Dim xmldoc As New XmlDocumentxmldoc.Load(Application.StartupPath & "\aiml\aiml.xml")Dim node As XmlNode = xmldoc.CreateNode(Xml.XmlNodeType.Element, "talk", "")xmldoc.DocumentElement.AppendChild(node)Dim node1 As XmlNode = xmldoc.CreateNode(Xml.XmlNodeType.Element, "question", "")node1.InnerText = qnode.AppendChild(node1)Dim node2 As XmlNode = xmldoc.CreateNode(Xml.XmlNodeType.Element, "answer", "")node2.InnerText = anode.AppendChild(node2)xmldoc.Save(Application.StartupPath & "\aiml\aiml.xml")Return NothingEnd Function'自動學習主函數Private Sub AutoStudy(ByVal str As String, ByVal answer As String)End Sub'對分詞結果的處理函數'這里還有Bug，不能進入系統Function GetSplitWords(ByVal SplitStr As String, ByVal OrangeStr As String) As StringDim SplitWords As New ArrayList '用于存儲分詞結果的處理Dim EncodeStart As Integer = 1Dim EncodeEnd As Integer = 1Dim j As Integer = 0DoDim s1 As Integer = EncodeStartDim e1 As Integer = EncodeEndEncodeStart = InStr(s1 + 1, SplitStr, "((")EncodeEnd = InStr(e1 + 1, SplitStr, ")")Dim tempstr As String = Mid(SplitStr, EncodeStart + 1, EncodeEnd - EncodeStart)SplitWords.Add(tempstr.Substring(1, SplitStr.IndexOf(",") - 2 + 1))j = j + 1Loop While EncodeEnd < Len(SplitStr) And EncodeStart < Len(SplitStr) '到此處已經獲取了所有分詞結果并單獨存儲'開始對分詞結果進行概率計算Dim Total As Integer = 0Dim T_lenth(SplitWords.Count) As IntegerDim T_location(SplitWords.Count) As IntegerDim E_rank(SplitWords.Count) As Double'分別獲取每個分詞結果的位置和長度，并循環累加算出總概率For i As Integer = 0 To SplitWords.CountT_lenth(i) = SplitWords(i).LengthT_location(i) = OrangeStr.IndexOf(SplitWords(i))Total = Total + T_lenth(i) * T_location(i)Next'計算每一個分詞結果的概率For i = 0 To SplitWords.CountE_rank(i) = T_lenth(i) * T_location(i) / TotalNext'選出概率最大的分詞結果System.Array.Sort(E_rank)Return NothingEnd Function'-----------------------------------------------------'-----------------------------------------------------'---------------機器學習部分函數結束------------------'-----------------------------------------------------'-----------------------------------------------------'-----------------------------------------------------'-----------------------------------------------------'--------------以下為可選模塊部分代碼-----------------'-----------------------------------------------------'-----------------------------------------------------Private Sub 詞典設置ToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles 詞典設置ToolStripMenuItem.ClickDictionary.Show()End SubPrivate Sub txtq_KeyPress(sender As Object, e As System.Windows.Forms.KeyPressEventArgs) Handles txtq.KeyPressEnd Sub'播放消息提示音Private Sub PlayMusic()If IsMsgWithSound = True ThenDim player As New System.Media.SoundPlayerplayer.SoundLocation = Application.StartupPath & "\wav\msg.wav"player.Load()player.Play()End IfEnd Sub'語音識別'Private Sub SoundRecognition()' If IsSoundRecognition = True Then' Dim RG As SpeechLib.ISpeechRecoGrammar' RG = RC.CreateGrammar(0)' RG.DictationLoad()' RG.DictationSetState(1)' Else' Exit Sub' End If'End Sub'語音監聽'Private Sub 聽到命令(ByVal StreamNumber As Integer, ByVal StreamPosition As Object, ByVal RecognitionType As SpeechLib.SpeechRecognitionType, ByVal 話語 As SpeechLib.ISpeechRecoResult) Handles RC.Recognition' txtq.Text = 話語.PhraseInfo.GetText()'End Sub'語音朗讀'Private Sub TalkWithSound(ByVal str)' If IsTalkWithSound = True Then' myvoice = New SpeechLib.SpVoice' myvoice.speak(str)' End If'End SubPrivate Sub 語音選項ToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles 語音選項ToolStripMenuItem.ClickSound.Show()End SubPrivate Sub 關于QRobotToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles 關于QRobotToolStripMenuItem.Clickabout.Show()End Sub End Class

?

總結

以上是生活随笔為你收集整理的开源聊天机器人程序QRobot（QuickRobot）的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。