classopenmind.cls

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

    While (Not rs.EOF)
      fromObject = rs("fromObject")
      ToObject = rs("toObject")
      fromObjectID = rs("fromObjectID")
      toObjectID = rs("toObjectID")
      ConnectionType = rs("ConnectionType")
      
      pos1 = InStr(ToObject, ",")
      pos2 = InStr(ToObject, " and ")
      If (pos1 > 0) And (pos2 > 0) And (pos2 > pos1) Then
      
        'lift and separate
        NoOfAttributes = 0
        attribStr = ""
        For i = 1 To Len(ToObject)
          c = Mid$(ToObject, i, 1)
          If (c = ",") Then
            attributeStr(NoOfAttributes) = attribStr
            attribStr = ""
            NoOfAttributes = NoOfAttributes + 1
            Else
            attribStr = attribStr & c
          End If
        Next
        If (Right$(ToObject, 1) <> ",") Then
          attributeStr(NoOfAttributes) = attribStr
          NoOfAttributes = NoOfAttributes + 1
        End If
        
        'remove the 'ands'
        For i = 0 To NoOfAttributes - 1
          pos1 = InStr(attributeStr(i), " and ")
          If (pos1 > 0) Then
            attributeStr(i) = Right$(attributeStr(i), Len(attributeStr(i)) - pos1 - 4)
          End If
          
          Call RemovePrefix(Trim(attributeStr(i)))
          
          'MsgBox fromObject & "  " & ConnectionType & "  " & attributeStr(i)
          Call ConnectObjects(fromObject, attributeStr(i), ConnectionType, Relationship)
        Next
        
        'delete the old entry
        Call DeleteConnection(fromObjectID, toObjectID, ConnectionType)
        
      End If
      rs.MoveNext
    Wend
  End If
  rs.Close

deriveListOfAttributes_exit:
  Exit Sub
deriveListOfAttributes_err:
  If (Err = 3022) Then 'duplicate detected
    Resume Next
  End If
  
  MsgBox "classOpenMind/deriveListOfAttributes/" & Err & "/" & Error$(Err)
  Resume deriveListOfAttributes_exit
End Sub




Public Sub deriveTypeOf()
'derives <x> is a type of <y> from entries of the type <x> isa <type 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("qDerivedTypeOf", 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, "type of ")
      If (pos = 0) Then
        pos = InStr(ToObject, "sort of ")
      End If
      If (pos = 0) Then
        pos = InStr(ToObject, "kind of ")
      End If
      If (pos > 0) Then
      
        parentObject = Trim(Right$(ToObject, Len(ToObject) - pos - 7))
        Call RemovePrefix(parentObject)
        
        Call ConnectObjects(fromObject, parentObject, "typeof", 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/deriveTypeOf/" & Err & "/" & Error$(Err)
  Resume deriveTypes_exit
End Sub



Public Sub derivePerson()
'derives <x> is a type of <person> from entries of the type <x> is <someone who 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 Relationship As String
  Dim ConnectionType As String
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qDerivedPerson", 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, "someone ")
      If (pos = 0) Then
        pos = InStr(ToObject, "somebody ")
      End If
      If (pos = 0) Then
        pos = InStr(ToObject, "person who ")
      End If
      If (pos > 0) Then
      
        'MsgBox ToObject & " is a type of person"
        If (ConnectionType = "isa") Or (ConnectionType = "is") Then
          Call ConnectObjects(fromObject, "person", "typeof", Relationship)
          Else
          Call ConnectObjects(ToObject, "person", "typeof", Relationship)
        End If
      
      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/derivePerson/" & Err & "/" & Error$(Err)
  Resume deriveTypes_exit
End Sub







Public Sub deriveLocation()
'derives <x> is located at <y> from entries of the type <x> is <located at 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
  Dim offset As Integer
  Dim compassLocation As Boolean
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qDerivedLocation", 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, "located in ")
      If (pos > 0) Then
        offset = 10
      End If
      
      If (pos = 0) Then
        pos = InStr(ToObject, "located at ")
        If (pos > 0) Then
          offset = 10
        End If
      End If
      
      If (pos = 0) Then
        pos = InStr(ToObject, "located on ")
        If (pos > 0) Then
          offset = 10
        End If
      End If
      
      If (pos = 0) Then
        pos = InStr(ToObject, "find in ")
        If (pos > 0) Then
          offset = 7
        End If
      End If
      
      If (pos = 0) Then
        pos = InStr(ToObject, "found in ")
        If (pos > 0) Then
          offset = 8
        End If
      End If
      
      If (pos = 0) Then
        pos = InStr(ToObject, "found on ")
        If (pos > 0) Then
          offset = 8
        End If
      End If
      
      
      If (pos > 0) Then
      
        parentObject = Trim(Right$(ToObject, Len(ToObject) - pos - offset))
        Call RemovePrefix(parentObject)
        
        compassLocation = False
        If (InStr(parentObject, "0") > 0) Or (InStr(parentObject, "1") > 0) Or (InStr(parentObject, "2") > 0) Or (InStr(parentObject, "3") > 0) Or (InStr(parentObject, "4") > 0) Or (InStr(parentObject, "5") > 0) Or (InStr(parentObject, "6") > 0) Or (InStr(parentObject, "7") > 0) Or (InStr(parentObject, "8") > 0) Or (InStr(parentObject, "9") > 0) Then
          If (InStr(parentObject, " n, ") > 0) Or (InStr(parentObject, " s, ") > 0) Or (InStr(parentObject, " n ") > 0) Or (InStr(parentObject, " s ") > 0) Then
            compassLocation = True
          End If
        End If
        
        If (compassLocation) Then
          Call ConnectObjects(parentObject, "geographical location", "isa", "")
          Call ConnectObjects(parentObject, "coordinate", "isa", "")
          Call ConnectObjects(parentObject, "global coordinate", "isa", "")
          Call ConnectObjects(parentObject, "point on the globe", "isa", "")
        End If
        
        Call ConnectObjects(fromObject, parentObject, "location", Relationship)
        Call DeleteConnection(fromObjectID, toObjectID, ConnectionType)
      
      End If
      rs.MoveNext
    Wend
  End If
  rs.Close
  
  Call ConnectObjects("geographical location", "planet earth", "inside", "")
  Call ConnectObjects("global coordinate", "planet earth", "inside", "")
  Call ConnectObjects("point on the globe", "planet earth", "inside", "")

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




Private Sub DeleteConnection(fromObjectID As Long, toObjectID As Long, ConnectionType As String)
'deletes the given connection
  Dim sqlStr As String
  
  Call OpenDatabase
  sqlStr = "DELETE * FROM tblConnections WHERE (([fromObjectID]=" & fromObjectID & ") AND "
  sqlStr = sqlStr & "([toObjectID]=" & toObjectID & ") AND ([ConnectionType]=" & Chr(34) & ConnectionType & Chr(34) & "));"
  db.Execute sqlStr
End Sub



Public Sub derivePastPresent()
  On Error GoTo derivePastPresent_err
  
  Dim rs As Recordset
  Dim fromID As Long
  Dim ToID As Long
  Dim connections As Recordset
  
  Call OpenDatabase
  Set rs = db.OpenRecordset("qEd", 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") = "presenttense"
      connections("Relationship") = "derived"
      connections.Update
      
      connections.AddNew
      connections("fromObjectID") = ToID
      connections("toObjectID") = fromID
      connections("ConnectionType") = "pasttense"
      connections("Relationship") = "derived"
      connections.Update
      rs.MoveNext
    Wend
    connections.Close
  End If
  rs.Close

derivePastPresent_exit:
  Exit Sub
derivePastPresent_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/derivePastPresent/" & Err & "/" & Error$(Err)
  Resume derivePastPresent_exit
End Sub





Private Function getStatement(rs As Recordset) As String
  Dim lineType As String
  Dim line As String
        
  lineType = rs("ConnectionType")
  Select Case lineType
    Case "collection"
      line = rs("FromObject") & " is often found with " & rs("toObject")
    Case "pasttense"
      line = rs("FromObject") & " is the past tense of " & rs("toObject")
    Case "presenttense"
      line = rs("FromObject") & " is the present tense of " & rs("toObject")
    Case "is"
      line = rs("FromObject") & " is part of " & rs("toObject")
    Case "partof"
      line = rs("FromObject") & " is part of " & rs("toObject")
    Case "shape"
      line = rs("FromObject") & " has shape " & rs("toObject")
    Case "isa"
      line = rs("FromObject") & " is a " & rs("toObject")
    Case "typeof"
      line = rs("FromObject") & " is a type of " & rs("toObject")
    Case "consequence"
      line = rs("toObject") & " is a consequence of " & rs("fromObject")
    Case "purpose"
      line = rs("fromObject") & " has the purpose of " & rs("toObject")
    Case "usage"
      line = rs("fromObject") & " can be used to " & rs("toObject")
    Case "different"
      line = rs("fromObject") & " is different from " & rs("toObject") & " because " & rs("Relationship")
    Case "wants"
      line = rs("fromObject") & " wants " & rs("toObject")
    Case "notwants"
      line = rs("fromObject") & " does not want " & rs("toObject")
    Case "similar"
      line = rs("fromObject") & " is similar to " & rs("toObject") & " because " & rs("Relationship")
    Case "similarderived"
      line = rs("fromObject") & " is similar to " & rs("toObject")
    Case "requires"
      line = rs("fromObject") & " requires " & rs("toObject")
    Case "belongs"
      line = rs("fromObject") & " belongs to " & rs("toObject")
    Case "inside"
      line = rs("fromObject") & " belongs within " & rs("toObject")
    Case "location"
      line = rs("fromObject") & " is located in " & rs("toObject")
    Case "usedin"
      line = rs("fromObject") & " is used in " & rs("toObject")
    Case "means"
      line = rs("fromObject") & " means " & rs("Relationship")
    Case "cando"
      line = rs("fromObject") & " can " & rs("toObject")
    Case "after"
      line = rs("fromObject") & " happens after " & rs("toObject")
    Case "desire"
      line = rs("fromObject") & " induces the desire to " & rs("toObject")
    Case "effect"
      line = "To " & rs("fromObject") & " you should " & rs("toObject")
    Case "possibleeffect"
      line = "Something that might happen when you " & rs("fromObject") & " is " & rs("toObject")
    Case "alternative"
      line = rs("toObject") & " is another way of saying " & rs("fromObject")
  End Select

  getStatement = line
End Function



Public Sub SearchResult(searchStr As String, lst As ListBox)
  Dim i As Integer
  Dim rs As Recordset
  Dim sqlStr As String
  
  sqlStr = "SELECT tblObjects.* From tblObjects WHERE "