fixed relation tuples

haskell-experiments/src/Datalog/NaiveDatabase.hs

@@ -74,17 +74,19 @@ withFacts facts =
     addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) =
       NaiveDatabase newRelationMap newConstantSet where
         newArity = length terms
-        newRelation = lookupRelation relationName relationMap newArity terms
+        newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms)
         newRelationMap = Map.insert relationName newRelation relationMap
         newConstantSet = Set.union constantSet $ Set.fromList terms
 
-lookupRelation :: RelationId -> Map RelationId Relation -> Int -> [Term] -> Relation
+lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation
-lookupRelation relationName relationMap newArity terms =
+lookupRelation relationName relationMap newArity tuples =
     case Map.lookup relationName relationMap of
-      Nothing -> Relation relationName newArity (Set.singleton terms) []
+      Nothing -> Relation relationName newArity tuples []
       Just relation ->
         if (_arity relation == newArity)
-          then Relation relationName (length terms) (Set.singleton terms) []
+          then
+            let newTuples = Set.union tuples $ _tuples relation
+            in Relation relationName newArity newTuples [] 
           else throw $ BadArityException relationName newArity
 
 data ConstraintElement = -- entry occurring in a rule body constraint - constant or variable index
@@ -149,7 +151,7 @@ withFactsAndRules facts rules =
       }  where
         relation = __relation context
         newArity = length terms
-        subRelation = lookupRelation subRelationName relationMap newArity terms
+        subRelation = lookupRelation subRelationName relationMap newArity Set.empty
         relationMap :: Map RelationId Relation = relations (_db context)
         relationMap' = Map.insert subRelationName subRelation relationMap
         extraVariables = toElement <$> terms
@@ -174,7 +176,7 @@ withFactsAndRules facts rules =
         relationName = predName ruleHead
         terms = arguments ruleHead
         newArity = length terms
-        relation = lookupRelation relationName (relations (_db context)) newArity terms
+        relation = lookupRelation relationName (relations (_db context)) newArity Set.empty
         context = RuleContext { 
           __relation = relation, 
           _headVariables = [], 
@@ -197,12 +199,6 @@ withFactsAndRules facts rules =
         extractVarName :: RuleElement -> Text
         extractVarName (RuleElementVariable varName) = varName
         extractVarName (RuleElementConstant constant) = throw $ UnexpectedConstantException constant
-        -- toBodyConstraint :: (Relation, [RuleElement]) -> BodyConstraint
-        -- toBodyConstraint (subRelation, ruleElements) =
-        --   BodyConstraint {
-        --     _relation = subRelation,
-        --     _elements = toConstraintElement <$> ruleElements
-        --   }
         newRule = RelationRule {
           headVariables = extractVarName <$> variables',
           body = fromBodyConstraint <$> (_bodyConstraints context'')
@@ -213,10 +209,6 @@ withFactsAndRules facts rules =
           toRuleElement :: ConstraintElement -> RuleElement
           toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
           toRuleElement (ConstraintElementIndex index) = variables' !! index
-        -- input is [(Relation, [RuleElement])]
-        -- bodyConstraint has
-        --   _relation :: Relation,
-        --   _elements :: [ConstraintElement]
         relation' = Relation {
           _name = _name relation,
           _arity = newArity,

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

@@ -21,7 +21,7 @@ import qualified Data.Map as Map
 
 spec :: Spec
 spec = do
-  describe "dummy test" $ do
+  describe "NaiveDatabase operations" $ do
     it "..." $ do
       1 `shouldBe` (1 :: Int)
     it "can ingest facts into relations & a universe" $ do
@@ -33,7 +33,7 @@ spec = do
       relations db `shouldBe`
         Map.fromList [
           ("parent",  
-            Relation "parent" 2 (Set.fromList ([Sym <$> ["bob", "carol"]])) [] )
+            Relation "parent" 2 (Set.fromList (map (Sym <$>) [["alice", "bob"], ["bob", "carol"]])) [] )
         ]
     it "can ingest facts and rules" $ do
       let db = NaiveDatabase.withFactsAndRules 
@@ -41,33 +41,28 @@ spec = do
             , "parent(\"bob\", \"carol\")." ]
             [ "ancestor(X,Y) :- parent(X,Y)."
             , "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." ]
+      constants db `shouldBe` 
+        (Set.fromList $ Sym <$> ["alice", "bob", "carol"])
       let parentRelation = Relation {
           _name = "parent",
           _arity = 2, 
-          _tuples = Set.fromList [
+          _tuples = Set.fromList $
-            [Var "X",Var "Z"]
+            map (Sym <$>) [["alice", "bob"], ["bob", "carol"]], 
-          ], 
           _rules = []
         }
       let ancestorRelation = Relation {
-          _name = "ancestor",
               _arity = 2, 
-          _tuples = Set.fromList [
+              _name = "ancestor",
-            [Var "Z",Var "Y"]
+              _tuples = Set.empty,
-          ], 
               _rules = []
             }
-      constants db `shouldBe` 
-        (Set.fromList $ Sym <$> ["alice", "bob", "carol"])
       relations db `shouldBe`
         Map.fromList [
           ("ancestor", 
           Relation {
               _arity = 2, 
               _name = "ancestor",
-              _tuples = Set.fromList [
+              _tuples = Set.empty,
-                [Var "X", Var "Y"]
-              ],
               _rules = [
                 RelationRule {
                   headVariables = [ "X", "Y", "Z" ], 
@@ -86,8 +81,7 @@ spec = do
                     ]
                   }
                 ]
-              }
+              } ),
-            ),
             ("parent", parentRelation )
           ]