classopenmind.cls

这个代码却能真正教会电脑进行像人那样思考

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassOpenMind"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public NoOfSnippets As Integer
Dim Snippet(32000, 4) As String

Public DatabaseName As String
Dim db As Database


Public Sub addSnippet(Level As Integer, ID As Integer, ParentID As Integer, phrase As String)
  Snippet(ID, 0) = LCase(phrase)
  Snippet(ID, 1) = ParentID
  Snippet(ID, 2) = Level
  Snippet(ID, 3) = CountWords(phrase)
  If (NoOfSnippets < ID) Then
    NoOfSnippets = ID
  End If
End Sub



Public Sub readOpenMind(filename As String)

  Dim fileNumber As Integer
  Dim c As String
  Dim nested As Integer
  Dim txt(1000) As String
  Dim ID(1000) As Integer
  Dim snippetID As Integer
  
  snippetID = 0
  nested = 0
  fileNumber = FreeFile
  Open filename For Input As fileNumber
  While (Not EOF(fileNumber))
    c = Input(1, #fileNumber)
    
    If (c = "(") Then
      nested = nested + 1
      snippetID = snippetID + 1
      ID(nested) = snippetID
      If (nested > 1) Then
        txt(nested - 1) = txt(nested - 1) & "#" & ID(nested - 1)
      End If
      
      Else
      If (c = ")") Then
        If (nested > 1) Then
          Call addSnippet(nested, ID(nested), ID(nested - 1), txt(nested))
          Else
          Call addSnippet(nested, ID(nested), -1, txt(nested))
        End If
        txt(nested) = ""
        nested = nested - 1
        Else
        If (nested > 0) And (c <> Chr(34)) Then
          txt(nested) = txt(nested) & c
        End If
      End If
    End If
  
  Wend
  Close #fileNumber

End Sub



Public Function getKnowledge(searchStr As String, Optional lst As Variant) As String
  Dim result As String
  Dim sqlStr As String
  Dim rs As Recordset
  Dim i As Integer
  Dim line As String
  Dim lineType As String
  Dim j As Integer
  
  Call OpenDatabase
  result = ""
  
  If (Not IsMissing(lst)) Then
    lst.Clear
  End If
  
  Set rs = db.OpenRecordset("tblCurrentvalues")
  rs.Edit
  rs("SearchString") = Trim(LCase(searchStr))
  rs.Update
  rs.Close
  
  For j = 0 To 1
    If (j = 0) Then
      Set rs = db.OpenRecordset("qSearch", dbOpenSnapshot)
      Else
      Set rs = db.OpenRecordset("qSearchReverse", dbOpenSnapshot)
    End If
    
    If (rs.RecordCount > 0) Then
      rs.MoveFirst
      For i = 1 To rs.RecordCount
        line = getStatement(rs)
        If (Not IsMissing(lst)) Then
          Call lst.AddItem(line)
        End If
        result = result & line & Chr(13)
        rs.MoveNext
      Next
    End If
    rs.Close
  Next
  
  getKnowledge = result
  
End Function


Public Function findRelationBetween(firstObject As String, secondObject As String)
  Dim rs As Recordset
  Dim sqlStr As String
  Dim itemsfound As Integer
  Dim returnStr As String
  Dim i As Integer
  Dim linkID As Long
  Dim ID As Long
  Dim finished As Boolean
  
  Call OpenDatabase
  db.Execute "qClearDiffusion"
  
  sqlStr = "SELECT * FROM tblObjects WHERE (([Name]=" & Chr(34) & firstObject & Chr(34) & ") OR "
  sqlStr = sqlStr & "([Name]=" & Chr(34) & secondObject & Chr(34) & "));"
  itemsfound = 0
  Set rs = db.OpenRecordset(sqlStr)
  If (rs.RecordCount > 0) Then
    rs.MoveFirst
    While (Not rs.EOF)
      If (rs("Name") = firstObject) Then
        rs.Edit
        rs("Value") = 1
        rs.Update
        itemsfound = itemsfound + 1
      End If
      If (rs("Name") = secondObject) Then
        rs.Edit
        rs("Value2") = 1
        rs.Update
        itemsfound = itemsfound + 1
      End If
      rs.MoveNext
    Wend
  End If
  rs.Close
  
  db.Recordsets.Refresh
  
  If (itemsfound = 2) Then
    
    itemsfound = 0
    i = 0
    While (i < 5) And (itemsfound = 0)
      db.Execute "qDiffuseValues"
      db.Execute "qDiffuseValues2"
      Set rs = db.OpenRecordset("qRelationMatches")
      itemsfound = rs.RecordCount
      If (itemsfound > 0) Then
        rs.MoveFirst
        linkID = rs("ID")
        'returnStr = getStatement(rs)
      End If
      rs.Close
      i = i + 1
    Wend
    
    If (itemsfound > 0) Then
      
      returnStr = ""
      i = 0
      ID = linkID
      finished = False
      While (Not finished) And (i < 6)
        sqlStr = "SELECT tblObjects.Name AS fromObject, tblObjects_1.Name AS "
        sqlStr = sqlStr & "toObject, tblConnections.ConnectionType, tblConnections.Relationship, tblObjects.* "
        sqlStr = sqlStr & "FROM (tblObjects INNER JOIN tblConnections ON "
        sqlStr = sqlStr & "tblObjects.ID = tblConnections.FromObjectID) INNER "
        sqlStr = sqlStr & "JOIN tblObjects AS tblObjects_1 ON tblConnections.ToObjectID = "
        sqlStr = sqlStr & "tblObjects_1.ID Where (((tblObjects.Value) > "
        sqlStr = sqlStr & "[tblObjects_1].[Value]) And ((tblObjects_1.ID) = "
        sqlStr = sqlStr & ID & ")) ORDER BY tblObjects.Value DESC;"

        Set rs = db.OpenRecordset(sqlStr, dbOpenSnapshot)
        If (rs.RecordCount > 0) Then
          rs.MoveFirst
          ID = rs("ID")
          If (i = 0) Then
            returnStr = getStatement(rs)
            Else
            returnStr = getStatement(rs) & Chr(13) & Chr(10) & returnStr
          End If
          If (rs("value") = 1) Then
            finished = True
          End If
        End If
        rs.Close
        i = i + 1
      Wend
      
      i = 0
      ID = linkID
      finished = False
      While (Not finished) And (i < 6)
        sqlStr = "SELECT tblObjects.Name AS fromObject, tblObjects_1.Name AS "
        sqlStr = sqlStr & "toObject, tblConnections.ConnectionType, tblConnections.Relationship, tblObjects.* "
        sqlStr = sqlStr & "FROM (tblObjects INNER JOIN tblConnections ON "
        sqlStr = sqlStr & "tblObjects.ID = tblConnections.FromObjectID) INNER "
        sqlStr = sqlStr & "JOIN tblObjects AS tblObjects_1 ON "
        sqlStr = sqlStr & "tblConnections.ToObjectID = tblObjects_1.ID "
        sqlStr = sqlStr & "Where (((tblObjects.value2) > [tblObjects_1].[value2]) "
        sqlStr = sqlStr & "And ((tblObjects_1.ID) = " & ID & ")) ORDER BY tblObjects.Value2 DESC;"

        Set rs = db.OpenRecordset(sqlStr, dbOpenSnapshot)
        If (rs.RecordCount > 0) Then
          rs.MoveFirst
          ID = rs("ID")
          returnStr = returnStr & Chr(13) & Chr(10) & getStatement(rs)
          If (rs("value2") = 1) Then
            finished = True
          End If
        End If
        rs.Close
        i = i + 1
      Wend
      
      Else
      returnStr = "The items given are unrelated"
    End If
    
    Else
    returnStr = "One or more of the objects could not be found"
  End If
  
  findRelationBetween = returnStr
End Function



Public Sub deriveTypes()
  On Error GoTo deriveTypes_err
  
  Dim rs As Recordset
  Dim fromID As Long
  Dim ToID As Long
  Dim connections As Recordset
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qTypeOf", dbOpenSnapshot)
  If (rs.RecordCount > 0) Then
    Set connections = db.OpenRecordset("tblConnections")
    rs.MoveFirst
    While (Not rs.EOF)
      fromID = rs("fromID")
      ToID = rs("toID")
      connections.AddNew
      connections("fromObjectID") = fromID
      connections("toObjectID") = ToID
      connections("ConnectionType") = "typeof"
      connections("Relationship") = "derived"
      connections.Update
      rs.MoveNext
    Wend
    connections.Close
  End If
  rs.Close

deriveTypes_exit:
  Exit Sub
deriveTypes_err:
  If (Err = 3022) Then 'duplicate detected
    Resume Next
    'rs.Close
    'connections.Close
    'Resume deriveTypes_exit
  End If
  
  'If (Err = 3001) Then 'invalid argument
  '  rs.Close
  '  connections.Close
  '  Resume deriveTypes_exit
  'End If

  MsgBox "classOpenMind/deriveTypes/" & Err & "/" & Error$(Err)
  Resume deriveTypes_exit
End Sub




Public Sub derivePartOf()
'derives <x> is part of <y> from entries of the type <x> is <part of y>
  On Error GoTo deriveTypes_err
  
  Dim rs As Recordset
  Dim fromObject As String
  Dim ToObject As String
  Dim fromObjectID As Long
  Dim toObjectID As Long
  Dim pos As Integer
  Dim parentObject As String
  Dim Relationship As String
  Dim ConnectionType As String
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qDerivedPartOf", dbOpenSnapshot)
  If (rs.RecordCount > 0) Then
    rs.MoveFirst
    While (Not rs.EOF)
      fromObject = rs("fromObject")
      ToObject = rs("toObject")
      fromObjectID = rs("fromObjectID")
      toObjectID = rs("toObjectID")
      ConnectionType = rs("ConnectionType")
      
      pos = InStr(ToObject, "part of ")
      If (pos > 0) Then
      
        parentObject = Trim(Right$(ToObject, Len(ToObject) - pos - 7))
        Call RemovePrefix(parentObject)
        
        Call ConnectObjects(fromObject, parentObject, "partof", Relationship)
        Call DeleteConnection(fromObjectID, toObjectID, ConnectionType)
      
      End If
      rs.MoveNext
    Wend
  End If
  rs.Close
  

deriveTypes_exit:
  Exit Sub
deriveTypes_err:
  If (Err = 3022) Then 'duplicate detected
    Resume Next
    'rs.Close
    'Resume deriveTypes_exit
  End If
  
  'If (Err = 3001) Then 'invalid argument
  '  rs.Close
  '  Resume deriveTypes_exit
  'End If

  MsgBox "classOpenMind/derivePartOf/" & Err & "/" & Error$(Err)
  Resume deriveTypes_exit
End Sub



Public Sub deriveCalled()
'derives <x> is part of <y> from entries of the type <x> is <part of y>
  On Error GoTo deriveCalled_err
  
  Dim rs As Recordset
  Dim fromObject As String
  Dim ToObject As String
  Dim fromObjectID As Long
  Dim toObjectID As Long
  Dim pos As Integer
  Dim firstObject As String
  Dim secondObject As String
  Dim Relationship As String
  Dim ConnectionType As String
  Dim offset As Integer
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qDerivedCalled", dbOpenSnapshot)
  If (rs.RecordCount > 0) Then
    rs.MoveFirst
    While (Not rs.EOF)
      fromObject = rs("fromObject")
      ToObject = rs("toObject")
      fromObjectID = rs("fromObjectID")
      toObjectID = rs("toObjectID")
      ConnectionType = rs("ConnectionType")
      
      pos = InStr(ToObject, " is called ")
      offset = 10
      If (pos = 0) Then
        pos = InStr(ToObject, " are called ")
        offset = 11
        If (pos = 0) Then
          pos = InStr(ToObject, " be called ")
          offset = 10
          If (pos = 0) Then
            pos = InStr(ToObject, " were called ")
            offset = 12
          End If
        End If
      End If
      
      If (pos > 0) Then
      
        firstObject = Trim(Left$(ToObject, pos))
        secondObject = Trim(Right$(ToObject, Len(ToObject) - pos - offset))
      
        Call RemovePrefix(firstObject)
        Call RemovePrefix(secondObject)
        
        MsgBox firstObject & "  called  " & secondObject
        
        'Call ConnectObjects(fromObject, parentObject, "partof", Relationship)
        'Call DeleteConnection(fromObjectID, toObjectID, ConnectionType)
      
      End If
      rs.MoveNext
    Wend
  End If
  rs.Close
  
deriveCalled_exit:
  Exit Sub
deriveCalled_err:
  If (Err = 3022) Then 'duplicate detected
    Resume Next
  End If
  
  MsgBox "classOpenMind/deriveCalled/" & Err & "/" & Error$(Err)
  Resume deriveCalled_exit
End Sub




Public Sub deriveListOfAttributes()
'splits up relationships of the form <x> ir <attrib1>, <attrib2>,... and <attrib3>
'into the component attributes
  On Error GoTo deriveListOfAttributes_err
  
  Dim rs As Recordset
  Dim fromObject As String
  Dim ToObject As String
  Dim fromObjectID As Long
  Dim toObjectID As Long
  Dim Relationship As String
  Dim ConnectionType As String
  Dim pos1 As Integer
  Dim pos2 As Integer
  Dim i As Integer
  Dim NoOfAttributes As Integer
  Dim attributeStr(100) As String
  Dim attribStr As String
  Dim c As String
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qDerivedList", dbOpenSnapshot)
  If (rs.RecordCount > 0) Then
    rs.MoveFirst