frmchecker.frm

非常著名的人工智能程序bob,想学人工智能的可以参考下.

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form FrmChecker 
   Caption         =   "Form1"
   ClientHeight    =   4725
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4500
   LinkTopic       =   "Form1"
   ScaleHeight     =   4725
   ScaleWidth      =   4500
   StartUpPosition =   3  'Windows Default
   Begin VB.Frame Frame1 
      Caption         =   "Info"
      Height          =   1965
      Left            =   30
      TabIndex        =   2
      Top             =   2700
      Width           =   4455
      Begin VB.TextBox Info 
         Height          =   1665
         Left            =   60
         Locked          =   -1  'True
         MultiLine       =   -1  'True
         TabIndex        =   3
         Top             =   210
         Width           =   4245
      End
   End
   Begin VB.TextBox InputArea 
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      Height          =   285
      Left            =   30
      TabIndex        =   0
      Text            =   "(InputArea)"
      Top             =   1620
      Width           =   4425
   End
   Begin RichTextLib.RichTextBox ResponseArea 
      Height          =   1545
      Left            =   60
      TabIndex        =   1
      Top             =   30
      Width           =   4395
      _ExtentX        =   7752
      _ExtentY        =   2725
      _Version        =   393217
      BorderStyle     =   0
      Enabled         =   -1  'True
      ReadOnly        =   -1  'True
      Appearance      =   0
      TextRTF         =   $"FrmChecker.frx":0000
   End
End
Attribute VB_Name = "FrmChecker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ReturnFunction As String
Dim TriggerKey As Boolean 'Clears text when mouse moves over
Dim BreakKey As Boolean
Dim BreakType As String

Private Sub Form_Load()
'    TextWindow.BorderStyle = rtfNoBorder
'    DisplayWindow.BorderStyle = 0
    ModFunctions.Username = "User"
    ReturnFunction = "GetUsername"
    InputArea = ""
    'ResponseArea = "[Bob] " & GetResponseForPreset("Preset3.txt", "0002")
    ResponseArea = ""
    AddColoredText "[Bob] " & GetResponseForPreset("Preset3.txt", "0002"), vbBlack, ResponseArea
    TriggerKey = True
    BreakKey = True
    BreakType = "but"
End Sub

Private Sub InputArea_Change()
    If BreakKey = True Then
        If LCase(InputArea.Text) = BreakType Then
            Dim sRes As Keyword
            sRes.KeywordFile = "Preset2.txt"
            sRes.KeywordNo = "0010"
            sRes.KeywordText = "[Bob] But"
            AddtoResponseArea GetRandomReply(sRes).ResponseText
            InputArea.Text = ""
        End If
    End If
End Sub

Private Sub InputArea_KeyPress(KeyAscii As Integer)
If TriggerKey = True Then
        InputArea = ""
        TriggerKey = False
End If

If KeyAscii = 13 Then
    'User hit enter
    Select Case ReturnFunction
        Case "GetUsername"
            Dim sGiven As String
            Dim sKey As Keyword
            Dim sResponse As Response
            
            sGiven = InputArea.Text
            InputArea.Text = ""
            If sGiven = "" Then sGiven = "{SILENCE}"
            sKey = KeywordSearchFile(UCase(sGiven), App.Path & "\data\preset1.txt")
            
            If sKey.KeywordText = "" Then
                If InStr(1, Trim(sGiven), " ") <> 0 Then
                    sKey.KeywordFile = "Preset2.txt"
                    sKey.KeywordNo = "0013"
                    sKey.KeywordText = sGiven
                    sKey.KeywordOrigin = sGiven
                Else
                    ModFunctions.Username = Trim(sGiven)
                    sKey.KeywordFile = "Preset3.txt"
                    sKey.KeywordNo = "0001"
                    sKey.KeywordText = sGiven
                    sKey.KeywordOrigin = sGiven
                    ReturnFunction = ""
                    BreakKey = False
                End If
            End If
            
            sResponse = GetRandomReply(sKey)
            AddColoredText "[" & ModFunctions.Username & "] " & sGiven, vbBlue, ResponseArea
            AddColoredText "[Bob] " & sResponse.ResponseText, vbBlack, ResponseArea
    
    Case Else
        Dim sReply As SimpleResponse
        sReply = GetKeywordReply(InputArea.Text)
        
        AddColoredText "[" & ModFunctions.Username & "] " & InputArea.Text, vbBlue, ResponseArea
        AddColoredText "[Bob] " & sReply.sReply, vbBlack, ResponseArea
        
        InputArea.Text = ""
        Info.Text = Info.Text & "Keyword Information" & Chr(13) & Chr(10)
        Info.Text = Info.Text & "Last Keyword: " & Reply.LastKeyword.KeywordText & Chr(13) & Chr(10)
        Info.Text = Info.Text & "Last File: " & Reply.LastKeyword.KeywordFile & Chr(13) & Chr(10)
        Info.Text = Info.Text & "Last Reference: " & Reply.LastKeyword.KeywordNo & Chr(13) & Chr(10)
        Info.Text = Info.Text & "Response Information" & Chr(13) & Chr(10)
        Info.Text = Info.Text & "Last Keyword: " & Reply.LastResponse.ResponseAction & Chr(13) & Chr(10)
    End Select
End If
End Sub


Public Sub AddtoResponseArea(sText As String)
    ResponseArea.Text = ResponseArea.Text & Chr(13) & Chr(10) & sText
    ResponseArea.SelStart = Len(ResponseArea.Text)
    'ResponseArea.Text = ResponseArea.Text & sText
End Sub

Sub AddColoredText(sText As String, sColor As ColorConstants, sTarget As RichTextBox)
    Dim sLength As Long
    
    sLength = Len(sTarget.Text)
    sTarget.SelStart = sLength
    sTarget.SelText = Chr(13) & Chr(10) & sText
    sTarget.SelStart = sLength
    sTarget.SelLength = Len(sTarget.Text) - sLength
    sTarget.SelColor = sColor
    
    sTarget.SelStart = Len(ResponseArea.Text)
End Sub