diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index 9c5860f..f874e71 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/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 relationName relationMap newArity terms = +lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation +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, diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 79dadf0..9105d74 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/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 [ - [Var "X",Var "Z"] - ], + _tuples = Set.fromList $ + map (Sym <$>) [["alice", "bob"], ["bob", "carol"]], _rules = [] } let ancestorRelation = Relation { - _name = "ancestor", - _arity = 2, - _tuples = Set.fromList [ - [Var "Z",Var "Y"] - ], - _rules = [] - } - constants db `shouldBe` - (Set.fromList $ Sym <$> ["alice", "bob", "carol"]) - relations db `shouldBe` - Map.fromList [ - ("ancestor", - Relation { _arity = 2, _name = "ancestor", - _tuples = Set.fromList [ - [Var "X", Var "Y"] - ], + _tuples = Set.empty, + _rules = [] + } + relations db `shouldBe` + Map.fromList [ + ("ancestor", + Relation { + _arity = 2, + _name = "ancestor", + _tuples = Set.empty, _rules = [ RelationRule { headVariables = [ "X", "Y", "Z" ], @@ -86,8 +81,7 @@ spec = do ] } ] - } - ), + } ), ("parent", parentRelation ) ]