sorted out rules engine, fixed bug about adding rules

haskell-experiments/haskell-experiments.cabal

@@ -89,6 +89,8 @@ library langfeatures
   hs-source-dirs:  src
   exposed-modules: Ologs, SimpleParser, ArithmeticParser, Datalog.DatalogParser, Datalog.NaiveDatabase
   ghc-options:     -Wall
+  default-extensions:
+    OverloadedStrings 
     
 executable haskell-experiments
   build-depends:    base, containers

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -21,7 +21,7 @@ import Text.Megaparsec (ParseErrorBundle)
 data NaiveDatabase = NaiveDatabase
   { relations :: Map RelationId Relation
   , constants :: Set Constant
-  }
+  } deriving (Show, Eq)
 
 data RuleElement -- entry occurring in a head or body relation - constant or variable
   = RuleElementConstant Constant
@@ -66,7 +66,7 @@ lookupRelation relationName relationMap newArity tuples =
     Just relation ->
       if _arity relation == newArity then
           let newTuples = Set.union tuples $ _tuples relation
-           in Relation relationName newArity newTuples []
+           in relation { _tuples = newTuples }
         else throw $ BadArityException relationName newArity
 
 withFacts :: [Text] -> NaiveDatabase
@@ -101,76 +101,91 @@ data RuleContext = RuleContext
   , _db :: NaiveDatabase
   }
 
+appendRule :: Relation -> RelationRule -> Relation
+appendRule relation rule =
+  relation {
+    _rules = rule : (_rules relation)
+  }
+  -- Relation { _name = _name relation
+  -- , _arity = _arity relation
+  -- , _tuples = _tuples relation
+  -- , _rules = rule : (_rules relation)
+  -- } 
+
+toRuleBodyElement :: BodyConstraint -> RuleBodyElement
+toRuleBodyElement (BodyConstraint subRelation elements) =
+  RuleBodyElement { 
+    _subRelationId = _name subRelation
+    , _ruleElements = elements
+    }
+
 withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
 withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
  where
-  extractRule :: Text -> (Literal, [Literal])
-  extractRule ruleText =
-    case parseDatalog ruleText of
-      Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs)
-      Right otherStatement -> throw $ NonRuleException ruleText otherStatement
-      Left ex -> throw $ CannotParseStatementException ruleText ex
-  digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
-  digestHead db relation (Literal neg relationName terms) =
-    RuleContext
-      { __relation = relation
-      , _variableNames = variableNames
-      , _headEntries = entries'
-      , _bodyConstraints = []
-      , _db = NaiveDatabase relationMap' constants'
-      }
-   where
-    variableNames = nub $ extractVariableNames terms
-    headTermToElement :: Term -> RuleElement
-    headTermToElement (Var name) = 
-      RuleElementVariable $ lookupVariable name variableNames
-    headTermToElement constant = RuleElementConstant constant
-    relationMap :: Map RelationId Relation = relations db
-    relationMap' = Map.insert relationName relation relationMap
-    extraVariables = headTermToElement <$> terms
-    entries' = nub extraVariables
-    extraConstants = mapMaybe extractConstant entries' where
-      extractConstant :: RuleElement -> Maybe Constant
-      extractConstant (RuleElementConstant constant) = Just constant
-      extractConstant _ = Nothing
-    constants' = Set.union (constants db) $ Set.fromList extraConstants
-  digestBody :: Literal -> RuleContext -> RuleContext
-  digestBody (Literal neg subRelationName subTerms) context =
-    RuleContext
-      { __relation = __relation context
-      , _variableNames = variableNames
-      , _headEntries = _headEntries context
-      , _bodyConstraints = newConstraint : constraints
-      , _db = NaiveDatabase relationMap' constants'
-      }
-   where
-    variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
-    newArity = length subTerms
-    subRelation = lookupRelation subRelationName relationMap newArity Set.empty
-    relationMap :: Map RelationId Relation = relations (_db context)
-    relationMap' = Map.insert subRelationName subRelation relationMap
-    extraConstants = mapMaybe constantFromTerm subTerms where
-      constantFromTerm :: Term -> Maybe Constant
-      constantFromTerm (Var _) = Nothing
-      constantFromTerm constant = Just constant
-    constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
-    constraints = _bodyConstraints context
-    newConstraint = BodyConstraint subRelation subRuleElements where
-      subRuleElements = toRuleElement <$> subTerms
-      toRuleElement :: Term -> RuleElement
-      toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames
-      toRuleElement constant = RuleElementConstant constant
 
-  lookupVariable :: Text -> [Text] -> Int
+extractRule :: Text -> (Literal, [Literal])
-  lookupVariable varName variableNames = 
+extractRule ruleText =
-    case elemIndex varName variableNames of
+  case parseDatalog ruleText of
-        Just index -> index
+    Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs)
-        Nothing -> throw $ VariableLookupException varName variableNames
+    Right otherStatement -> throw $ NonRuleException ruleText otherStatement
+    Left ex -> throw $ CannotParseStatementException ruleText ex
+digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
+digestHead db relation (Literal neg relationName terms) =
+  RuleContext
+    { __relation = relation
+    , _variableNames = variableNames
+    , _headEntries = entries'
+    , _bodyConstraints = []
+    , _db = NaiveDatabase relationMap' constants'
+    }
+ where
+  variableNames = nub $ extractVariableNames terms
+  headTermToElement :: Term -> RuleElement
+  headTermToElement (Var name) = 
+    RuleElementVariable $ lookupVariable name variableNames
+  headTermToElement constant = RuleElementConstant constant
+  relationMap :: Map RelationId Relation = relations db
+  relationMap' = Map.insert relationName relation relationMap
+  extraVariables = headTermToElement <$> terms
+  entries' = nub extraVariables
+  extraConstants = mapMaybe extractConstant entries' where
+    extractConstant :: RuleElement -> Maybe Constant
+    extractConstant (RuleElementConstant constant) = Just constant
+    extractConstant _ = Nothing
+  constants' = Set.union (constants db) $ Set.fromList extraConstants
+digestBody :: Literal -> RuleContext -> RuleContext
+digestBody (Literal neg subRelationName subTerms) context =
+  context { 
+    _variableNames = variableNames
+    , _bodyConstraints = newConstraint : constraints
+    , _db = NaiveDatabase relationMap' constants'
+    }
+ where
+  variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
+  newArity = length subTerms
+  subRelation = lookupRelation subRelationName relationMap newArity Set.empty
+  relationMap :: Map RelationId Relation = relations (_db context)
+  relationMap' = Map.insert subRelationName subRelation relationMap
+  extraConstants = mapMaybe constantFromTerm subTerms where
+    constantFromTerm :: Term -> Maybe Constant
+    constantFromTerm (Var _) = Nothing
+    constantFromTerm constant = Just constant
+  constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
+  constraints = _bodyConstraints context
+  newConstraint = BodyConstraint subRelation subRuleElements where
+    subRuleElements = toRuleElement <$> subTerms
+    toRuleElement :: Term -> RuleElement
+    toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames
+    toRuleElement constant = RuleElementConstant constant
+lookupVariable :: Text -> [Text] -> Int
+lookupVariable varName variableNames = 
+  case elemIndex varName variableNames of
+      Just index -> index
+      Nothing -> throw $ VariableLookupException varName variableNames
 
-  addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
+addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
-  addRule (ruleHead, body) db  =
+addRule (ruleHead, body) db  =
-    NaiveDatabase relationMap' constants'
+  NaiveDatabase relationMap' constants' where
-   where
     relationName = predName ruleHead
     terms = arguments ruleHead
     newArity = length terms
@@ -179,31 +194,49 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
     context' = foldr digestBody context body
     db' = _db context'
     relationMap = relations db'
-    relation' =
+    relation' = appendRule relation RelationRule { 
-      Relation
+        headVariables = _variableNames context'
-        { _name = _name relation
+        , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
-        , _arity = newArity
+      }
-        , _tuples = _tuples relation
-        , _rules = newRule : _rules relation
-        } where
-      newRule =
-        RelationRule
-          { headVariables = _variableNames context'
-          , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
-          }
-      toRuleBodyElement :: BodyConstraint -> RuleBodyElement
-      toRuleBodyElement (BodyConstraint subRelation elements) =
-        RuleBodyElement { 
-          _subRelationId = _name subRelation
-          , _ruleElements = elements
-          }
     relationMap' = Map.insert relationName relation' relationMap
     constants' = constants db'
-  extractVariableNames :: [Term] -> [Text]
+-- addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
-  extractVariableNames = mapMaybe extractVariableName where
+-- addRule (ruleHead, body) db  =
-    extractVariableName :: Term -> Maybe Text
+--   NaiveDatabase relationMap' constants'
-    extractVariableName (Var name) = Just name
+--  where
-    extractVariableName _ = Nothing
+--   relationName = predName ruleHead
+--   terms = arguments ruleHead
+--   newArity = length terms
+--   relation = lookupRelation relationName (relations db) newArity Set.empty
+--   context = digestHead db relation ruleHead
+--   context' = foldr digestBody context body
+--   db' = _db context'
+--   relationMap = relations db'
+--   relation' =
+--     Relation
+--       { _name = _name relation
+--       , _arity = newArity
+--       , _tuples = _tuples relation
+--       , _rules = newRule : _rules relation
+--       } where
+--     newRule =
+--       RelationRule
+--         { headVariables = _variableNames context'
+--         , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
+--         }
+--     toRuleBodyElement :: BodyConstraint -> RuleBodyElement
+--     toRuleBodyElement (BodyConstraint subRelation elements) =
+--       RuleBodyElement { 
+--         _subRelationId = _name subRelation
+--         , _ruleElements = elements
+--         }
+--   relationMap' = Map.insert relationName relation' relationMap
+--   constants' = constants db'
+extractVariableNames :: [Term] -> [Text]
+extractVariableNames = mapMaybe extractVariableName where
+  extractVariableName :: Term -> Maybe Text
+  extractVariableName (Var name) = Just name
+  extractVariableName _ = Nothing
 
 query :: NaiveDatabase -> Text -> Text
 query db qText =

haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedRecordDot #-}
@@ -8,9 +9,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoFieldSelectors #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 module Test.Datalog.NaiveDatabaseSpec where
 
@@ -25,10 +25,11 @@ spec :: Spec
 spec = do
   describe "NaiveDatabase operations" do
     it "can ingest facts into relations & a universe" $ do
-      let db = NaiveDatabase.withFacts
+      let db =
-            [ "parent(\"alice\", \"bob\")."
+            NaiveDatabase.withFacts
-            , "parent(\"bob\", \"carol\")."
+              [ "parent(\"alice\", \"bob\")."
-            ]
+              , "parent(\"bob\", \"carol\")."
+              ]
       constants db
         `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
       relations db
@@ -39,14 +40,14 @@ spec = do
             )
           ]
     it "can ingest facts and rules" do
-      let db = NaiveDatabase.withFactsAndRules
+      let db =
-            [ "parent(\"alice\", \"bob\")."
+            NaiveDatabase.withFactsAndRules
-            , "parent(\"bob\", \"carol\")."
+              [ "parent(\"alice\", \"bob\")."
-            ]
+              , "parent(\"bob\", \"carol\")."
-            [
+              ]
-              "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."
+              [ "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."
-            , "ancestor(X,Y) :- parent(X,Y)." 
+              , "ancestor(X,Y) :- parent(X,Y)."
-            ]
+              ]
           parentRelation =
             Relation
               { _name = "parent"
@@ -56,8 +57,7 @@ spec = do
                     map (Sym <$>) [["alice", "bob"], ["bob", "carol"]]
               , _rules = []
               }
-          ancestorRule =
+          ancestorRule = RelationRule
-            RelationRule
               { headVariables = ["X", "Y", "Z"]
               , bodyElements =
                   [ RuleBodyElement
@@ -76,15 +76,26 @@ spec = do
                       }
                   ]
               }
+          ancestorRule2 = RelationRule
+              { headVariables = ["X", "Y"]
+              , bodyElements =
+                  [ RuleBodyElement
+                      { _subRelationId = "parent"
+                      , _ruleElements = [RuleElementVariable 0, RuleElementVariable 1]
+                      }
+                  ]
+              }
           ancestorRelation =
             Relation
               { _arity = 2
               , _name = "ancestor"
               , _tuples = Set.empty
-              , _rules = [ancestorRule]
+              , _rules = [ancestorRule, ancestorRule2]
               }
+
       constants db
         `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"])
+
       relations db
         `shouldBe` Map.fromList
           [ ("ancestor", ancestorRelation)
@@ -137,11 +148,95 @@ spec = do
       constants db
         `shouldBe` Set.empty
 
+    it "can ingest facts and rules with duplicate head entries" do
+      let db =
+            NaiveDatabase.withFactsAndRules
+              []
+              ["equivalent(Q,Q) :- ."]
+          rule1 =
+            RelationRule
+              { headVariables = ["Q"]
+              , bodyElements = []
+              }
+
+          equivalentRelation =
+            Relation
+              { _arity = 2
+              , _name = "equivalent"
+              , _tuples = Set.empty
+              , _rules = [rule1]
+              }
+      relations db
+        `shouldBe` Map.singleton "equivalent" equivalentRelation
+
+      constants db
+        `shouldBe` Set.empty
+
+    it "can ingest a theory of equivalence relations" do
+      let db =
+            NaiveDatabase.withFactsAndRules
+              []
+              [ "equivalent(Q,Q) :- ."
+              , "equivalent(R,Q) :- equivalent(Q,R)."
+              , "equivalent(Q,S) :- equivalent(Q,R), equivalent(R,S)."
+              ]
+          rule1 =
+            RelationRule
+              { headVariables = ["Q"]
+              , bodyElements = []
+              }
+          rule2 =
+            RelationRule
+              { headVariables = ["R", "Q"]
+              , bodyElements =
+                  [ RuleBodyElement
+                      { _subRelationId = "equivalent"
+                      , _ruleElements =
+                          [ RuleElementVariable 1
+                          , RuleElementVariable 0
+                          ]
+                      }
+                  ]
+              }
+          rule3 =
+            RelationRule
+              { headVariables = ["Q", "S", "R"]
+              , bodyElements =
+                  [ RuleBodyElement
+                      { _subRelationId = "equivalent"
+                      , _ruleElements =
+                          [ RuleElementVariable 0
+                          , RuleElementVariable 2
+                          ]
+                      }
+                  , RuleBodyElement
+                      { _subRelationId = "equivalent"
+                      , _ruleElements =
+                          [ RuleElementVariable 2
+                          , RuleElementVariable 1
+                          ]
+                      }
+                  ]
+              }
+          equivalentRelation =
+            Relation
+              { _arity = 2
+              , _name = "equivalent"
+              , _tuples = Set.empty
+              , _rules = [rule1, rule2, rule3]
+              }
+      relations db
+        `shouldBe` Map.singleton "equivalent" equivalentRelation
+
+      constants db
+        `shouldBe` Set.empty
+
     it "can do basic queries" do
-      let db = NaiveDatabase.withFacts
+      let db =
-            [ "parent(\"alice\", \"bob\")."
+            NaiveDatabase.withFacts
-            , "parent(\"bob\", \"carol\")."
+              [ "parent(\"alice\", \"bob\")."
-            ]
+              , "parent(\"bob\", \"carol\")."
+              ]
       query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob'
 
 (<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)