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,9 +101,28 @@ 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
@@ -136,10 +155,8 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
   constants' = Set.union (constants db) $ Set.fromList extraConstants
 digestBody :: Literal -> RuleContext -> RuleContext
 digestBody (Literal neg subRelationName subTerms) context =
-    RuleContext
+  context { 
-      { __relation = __relation context
+    _variableNames = variableNames
-      , _variableNames = variableNames
-      , _headEntries = _headEntries context
     , _bodyConstraints = newConstraint : constraints
     , _db = NaiveDatabase relationMap' constants'
     }
@@ -160,7 +177,6 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
     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
@@ -169,8 +185,7 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
 
 addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
 addRule (ruleHead, body) db  =
-    NaiveDatabase relationMap' constants'
+  NaiveDatabase relationMap' constants' where
-   where
     relationName = predName ruleHead
     terms = arguments ruleHead
     newArity = length terms
@@ -179,26 +194,44 @@ 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
-        , _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'
+-- addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
+-- addRule (ruleHead, body) db  =
+--   NaiveDatabase relationMap' constants'
+--  where
+--   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

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,7 +25,8 @@ spec :: Spec
 spec = do
   describe "NaiveDatabase operations" do
     it "can ingest facts into relations & a universe" $ do
-      let db = NaiveDatabase.withFacts
+      let db =
+            NaiveDatabase.withFacts
               [ "parent(\"alice\", \"bob\")."
               , "parent(\"bob\", \"carol\")."
               ]
@@ -39,12 +40,12 @@ spec = do
             )
           ]
     it "can ingest facts and rules" do
-      let db = NaiveDatabase.withFactsAndRules
+      let db =
+            NaiveDatabase.withFactsAndRules
               [ "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)."
               ]
           parentRelation =
@@ -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,8 +148,92 @@ 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 =
+            NaiveDatabase.withFacts
               [ "parent(\"alice\", \"bob\")."
               , "parent(\"bob\", \"carol\")."
               ]