开源聊天机器人程序QRobot（QuickRobot）

之前写的，本来打算写成开源类库的，可是用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.IO





Public Class chat

    Public XmlPath As String    '语料数据路径
    Public username As String '使用者名字
    Public robotname As String '机器人名字
    Dim myvoice As Object  '创建语音选项
    Dim systime As String
    Dim a As String
    Dim q As String
    ' Public WithEvents RC As New SpeechLib.SpSharedRecoContext
    Dim 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 '用于窗体的移动



    '对话过程Cmdtalk
    Private Sub Cmdtalk_Click() Handles Cmdtalk.Click
        q = txtq.Text
        systime = DateTime.Now.Hour & ":" & DateTime.Now.Minute & ":" & DateTime.Now.Second
        txtans.Text = txtans.Text & vbNewLine & vbNewLine & systime & Space(2) & "【" & username & "】" & "说:" & vbNewLine & q
        PlayMusic()
        a = Response(q)
        '开始匹配答案 核心部分
        txtans.Text = txtans.Text & vbNewLine & vbNewLine & systime & Space(2) & "【" & robotname & "】" & "说:" & vbNewLine & a
        txtans.SelectionStart = Len(txtans.Text & vbNewLine & vbNewLine) '选择文本插入点，给下面的文字空出空间
        txtans.ScrollToCaret() '滚动条滚动开始
        '自动学习开始()
        lastq = q  '记录前一个问题的内容
        lasta = a  '记录前一个问题的答案
        If XpathToXml(lastq) = 0 And lasta <> "莉莉不知道怎样回答" Then
            AddNewKnowledge(lastq, lasta)
        End If
        txtq.Text = ""
    End Sub


    '页面初始化主函数
    Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        Randomize()
        LoadCmd() '加载命令列表
        IsTalkWithSound = False
        IsSoundRecognition = False
        username = "我"
        robotname = "莉莉"
        systime = DateTime.Now.Hour & ":" & DateTime.Now.Minute & ":" & DateTime.Now.Second
        txtans.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 XmlDocument
        xmldoc.Load(Application.StartupPath & "\aiml\cmd.xml")
        Dim nodeList As XmlNodeList
        Dim root As XmlElement = xmldoc.DocumentElement
        nodeList = root.SelectNodes("/cmdlist/cmd")
        Dim a As String = ""
        Dim node As XmlNode = Nothing
        For Each node In nodeList
            CmdList.Add(node.InnerText)
        Next
    End Sub

    '分词模块，比较简单，没想到中科院的效果那么差
    Public Function SplitWords(ByVal input As String) As String
        Dim sb As New StringBuilder()
        sb.Remove(0, sb.Length)
        Dim t1 As String = ""
        Dim i As Integer = 0
        Dim analyzer = New Lucene.Net.Analysis.China.ChineseAnalyzer
        Dim sr As New StringReader(input)
        Dim stream As TokenStream
        stream = analyzer.TokenStream("", sr)
        Dim t As Token = stream.Next()
        While t Is Nothing = False
            t1 = t.ToString()
            t1 = t1.Replace("(", "")
            sb.Append(i & ":" & "(" & t1)
            t = stream.Next()
            i += 1
        End While
        SplitWords = sb.ToString()
    End Function

    '机器人反应函数Response
    Public Function Response(ByVal str As String) As String
        '这里指定所有的命令函数格式为：“函数名：参数一|参数二|参数三.....”
        Response = ""
        If InStr(str, "：") > 0 Then
            Dim 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 CmdStr
                    Case "天气"
                        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 Select
            End If
        Else
            If XpathToXml(str) > 0 Then  '在本地查找满足模糊条件的数据
                Response = GetLocalData(XpathToXml(str) - 1)
            Else
                Response = getWebData(str)
            End If
        End If
        Return Response
    End Function
    '-----------------------------------------------------
    '-----------------------------------------------------
    '---------- 这里是用于扩展程序功能的插件--------------
    '-----------------------------------------------------
    '-----------------------------------------------------
    Function Plugin_Translate(ByVal q As String) As String
        Dim translate As New youdaoTranslate
        Return translate.DoTranslate(q)
    End Function

    Function Plugin_Weather(ByVal city As String) As String
        Return Nothing
    End Function

    Function Plugin_Search(ByVal keywords As String) As String
        browser.Show()
        browser.WebBrowser1.Navigate("http://www.baidu.com/s?wd=" + keywords)
        Return "莉莉已经完成对" + "[" + keywords + "]" + "的搜索"
    End Function

    Function Plugin_Math(ByVal expression As String) As String
        Dim ScriptClass As New MSScriptControl.ScriptControl
        ScriptClass.Language = "javascript"
        Dim obj As Object = ScriptClass.Eval(expression)
        Return expression + "=" + obj.ToString()
    End Function

    Function PlugIn_Map()
        Return ""
    End Function

    Function Plugin_Baike()
        Return ""
    End Function
    '-----------------------------------------------------
    '-----------------------------------------------------
    '---------------插件部分的代码到此结束----------------
    '-----------------------------------------------------
    '-----------------------------------------------------




    '-----------------------------------------------------
    '-----------------------------------------------------
    '---------这里是用于从网络获取聊天数据的程序----------
    '-----------------------------------------------------
    '-----------------------------------------------------

    '从网络上获取数据
    Function getWebData(ByVal str As String) As String
        Dim webbot As New Simsimi
        Dim cookie As String = webbot.getcookie()
        If webbot.showmsg(str, cookie) = "{}" Then
            Return "莉莉累了，休息一会儿....."
        Else
            Return webbot.showmsg(str, cookie)
        End If
    End Function


    '-----------------------------------------------------
    '-----------------------------------------------------
    '-----------------------结束--------------------------
    '-----------------------------------------------------
    '-----------------------------------------------------


    '-----------------------------------------------------
    '-----------------------------------------------------
    '-------------------本地数据搜索模块------------------
    '-----------------------------------------------------
    '-----------------------------------------------------
    '基于Xpath的模糊匹配,返回满足要求的数据-问题索引
    Public Function XpathToXml(ByVal str As String) As Integer
        Dim IndexList As New ArrayList '用于保存满足匹配条件的索引列表
        Dim pos As Integer
        Dim i As Integer = 0
        Dim xmldoc1 As New XmlDocument
        xmldoc1.Load(Application.StartupPath & "\aiml\aiml.xml")
        Dim nodeList As XmlNodeList
        Dim root As XmlElement = xmldoc1.DocumentElement
        nodeList = root.SelectNodes("/aiml/talk/question")
        Dim node As XmlNode = Nothing
        For Each node In nodeList
            Dim q As String = node.InnerText
            i = i + 1
            If str = q Or InStr(SplitWords(str), q) > 0 Then  '如果满足条件就保存当前索引到IndexList
                IndexList.Add(i)
            End If
        Next
        If IndexList.Count = 0 Then '假如列表中没有符合要求的索引
            pos = 0
        Else
            pos = IndexList(Int(Rnd() * (IndexList.Count))) '否则返回索引列表中的随机索引值，加1是为了了避免出现1的错误，这样会导致回答索引为0
            If pos = 1 Then pos = pos + 1 '避免因为随机数而导致的出现答案索引为0的情形
        End If
        Return pos
    End Function

    '获取本地指定索引的数据-答案
    Public Function GetLocalData(ByVal index As Integer) As String
        Dim pos As Integer = 0
        Dim xmldoc1 As New XmlDocument
        xmldoc1.Load(Application.StartupPath & "\aiml\aiml.xml")
        Dim nodeList As XmlNodeList
        Dim root As XmlElement = xmldoc1.DocumentElement
        nodeList = root.SelectNodes("/aiml/talk/answer")
        Dim a As String = ""
        Dim node As XmlNode = Nothing
        For Each node In nodeList
            a = node.InnerText
            pos = pos + 1
            If pos > index Then
                Exit For
            End If
        Next
        Return a
    End Function
    '-----------------------------------------------------
    '-----------------------------------------------------
    '---------------本地数据搜索模块结束------------------
    '-----------------------------------------------------
    '-----------------------------------------------------

    '*****************************************************

    '-----------------------------------------------------
    '-----------------------------------------------------
    '---------------机器学习部分函数模块------------------
    '-----------------------------------------------------
    '-----------------------------------------------------
    '添加新知识到xml存档
    Public Function AddNewKnowledge(ByVal q As String, ByVal a As String)
        Dim xmldoc As New XmlDocument
        xmldoc.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 = q
        node.AppendChild(node1)
        Dim node2 As XmlNode = xmldoc.CreateNode(Xml.XmlNodeType.Element, "answer", "")
        node2.InnerText = a
        node.AppendChild(node2)
        xmldoc.Save(Application.StartupPath & "\aiml\aiml.xml")
        Return Nothing
    End 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 String
        Dim SplitWords As New ArrayList  '用于存储分词结果的处理
        Dim EncodeStart As Integer = 1
        Dim EncodeEnd As Integer = 1
        Dim j As Integer = 0
        Do
            Dim s1 As Integer = EncodeStart
            Dim e1 As Integer = EncodeEnd
            EncodeStart = 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 + 1
        Loop While EncodeEnd < Len(SplitStr) And EncodeStart < Len(SplitStr)  '到此处已经获取了所有分词结果并单独存储
        '开始对分词结果进行概率计算
        Dim Total As Integer = 0
        Dim T_lenth(SplitWords.Count) As Integer
        Dim T_location(SplitWords.Count) As Integer
        Dim E_rank(SplitWords.Count) As Double
        '分别获取每个分词结果的位置和长度，并循环累加算出总概率
        For i As Integer = 0 To SplitWords.Count
            T_lenth(i) = SplitWords(i).Length
            T_location(i) = OrangeStr.IndexOf(SplitWords(i))
            Total = Total + T_lenth(i) * T_location(i)
        Next
        '计算每一个分词结果的概率
        For i = 0 To SplitWords.Count
            E_rank(i) = T_lenth(i) * T_location(i) / Total
        Next
        '选出概率最大的分词结果
        System.Array.Sort(E_rank)
        Return Nothing
    End Function
    '-----------------------------------------------------
    '-----------------------------------------------------
    '---------------机器学习部分函数结束------------------
    '-----------------------------------------------------
    '-----------------------------------------------------




    '-----------------------------------------------------
    '-----------------------------------------------------
    '--------------以下为可选模块部分代码-----------------
    '-----------------------------------------------------
    '-----------------------------------------------------
    Private Sub 词典设置ToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles 词典设置ToolStripMenuItem.Click
        Dictionary.Show()
    End Sub

    Private Sub txtq_KeyPress(sender As Object, e As System.Windows.Forms.KeyPressEventArgs) Handles txtq.KeyPress
    End Sub
    '播放消息提示音
    Private Sub PlayMusic()
        If IsMsgWithSound = True Then
            Dim player As New System.Media.SoundPlayer
            player.SoundLocation = Application.StartupPath & "\wav\msg.wav"
            player.Load()
            player.Play()
        End If
    End 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 Sub

    Private Sub 语音选项ToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles 语音选项ToolStripMenuItem.Click
        Sound.Show()
    End Sub

    Private Sub 关于QRobotToolStripMenuItem_Click(sender As System.Object, e As System.EventArgs) Handles 关于QRobotToolStripMenuItem.Click
        about.Show()
    End Sub
End Class