From 2828825f02ac096f7f6dfc512759aca858e276bc Mon Sep 17 00:00:00 2001 From: Felix Dilke Date: Fri, 30 Jan 2026 14:37:45 +0000 Subject: [PATCH] factored out addFact, addRule --- haskell-experiments/src/Datalog/DatalogDB.hs | 94 ++++++++++++++++++- .../src/Datalog/NaiveDatabase.hs | 92 ------------------ haskell-experiments/src/Datalog/Rules.hs | 1 + 3 files changed, 93 insertions(+), 94 deletions(-) diff --git a/haskell-experiments/src/Datalog/DatalogDB.hs b/haskell-experiments/src/Datalog/DatalogDB.hs index 2f3ed80..1383a9e 100644 --- a/haskell-experiments/src/Datalog/DatalogDB.hs +++ b/haskell-experiments/src/Datalog/DatalogDB.hs @@ -23,7 +23,97 @@ class DatalogDB db where emptyDB :: db lookupRelation :: db -> Text -> Maybe Relation insertRelation :: db -> Relation -> db - addFact :: Literal -> db -> db - addRule :: (Literal, [Literal]) -> db -> db addConstants :: db -> Set Constant -> db +lookupRelationArity :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation +lookupRelationArity relationName db newArity tuples = + case lookupRelation db relationName of + Nothing -> Relation relationName newArity tuples [] + Just relation -> + if _arity relation == newArity then + let newTuples = Set.union tuples $ _tuples relation + in relation { _tuples = newTuples } + else throw $ BadArityException relationName newArity + +addFact :: (DatalogDB db) => Literal -> db -> db +addFact (Literal neg relationName terms) db = + insertRelation (addConstants db extraConstants) newRelation + where + newArity = length terms + newRelation = lookupRelationArity relationName db newArity (Set.singleton terms) + extraConstants = Set.fromList terms + +addRule :: (DatalogDB db) => (Literal, [Literal]) -> db -> db +addRule (ruleHead, body) db = + insertRelation db' newRelation + where + relationName = predName ruleHead + terms = arguments ruleHead + newArity = length terms + relation = lookupRelationArity relationName db newArity Set.empty + context = digestHead db relation ruleHead + context' = foldr digestBody context body + db' = _db context' + newRelation = appendRule relation RelationRule { + headVariables = _variableNames context' + , bodyElements = toRuleBodyElement <$> _bodyConstraints context' + } + +data (DatalogDB db) => RuleContext db = RuleContext + { __relation :: Relation + , _variableNames :: [Text] + , _headEntries :: [RuleElement] + , _bodyConstraints :: [BodyConstraint] + , _db :: db + } + +digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db +digestHead db relation (Literal neg relationName terms) = + RuleContext + { __relation = relation + , _variableNames = variableNames + , _headEntries = entries' + , _bodyConstraints = [] + , _db = insertRelation (addConstants db extraConstants) relation + } + where + variableNames = nub $ extractVariableNames terms + entries' = nub $ (headTermToElement variableNames) <$> terms + extraConstants = Set.fromList $ mapMaybe extractConstant entries' where + extractConstant :: RuleElement -> Maybe Constant + extractConstant (RuleElementConstant constant) = Just constant + extractConstant _ = Nothing +digestBody :: (DatalogDB db) => Literal -> RuleContext db -> RuleContext db +digestBody (Literal neg subRelationName subTerms) context = + context { + _variableNames = variableNames + , _bodyConstraints = newConstraint : constraints + , _db = insertRelation (addConstants db constants') subRelation + } + where + db = _db context + variableNames = nub $ _variableNames context ++ extractVariableNames subTerms + newArity = length subTerms + subRelation = lookupRelationArity subRelationName (_db context) newArity Set.empty + extraConstants = mapMaybe constantFromTerm subTerms where + constantFromTerm :: Term -> Maybe Constant + constantFromTerm (Var _) = Nothing + constantFromTerm constant = Just constant + constants' = 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 + +headTermToElement :: [Text] -> Term -> RuleElement +headTermToElement variableNames (Var name) = + RuleElementVariable $ lookupVariable name variableNames +headTermToElement _ constant = RuleElementConstant constant diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index f38d9bc..5f512f6 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -43,46 +43,12 @@ instance DatalogDB NaiveDatabase where relations = Map.insert (_name relation) relation (relations db) } - addFact :: Literal -> NaiveDatabase -> NaiveDatabase - addFact (Literal neg relationName terms) db@(NaiveDatabase relationMap constantSet) = - insertRelation (addConstants db extraConstants) newRelation - where - newArity = length terms - newRelation = lookupRelation0 relationName db newArity (Set.singleton terms) - extraConstants = Set.fromList terms - - addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase - addRule (ruleHead, body) db = - insertRelation db' newRelation - where - relationName = predName ruleHead - terms = arguments ruleHead - newArity = length terms - relation = lookupRelation0 relationName db newArity Set.empty - context = digestHead db relation ruleHead - context' = foldr digestBody context body - db' = _db context' - newRelation = appendRule relation RelationRule { - headVariables = _variableNames context' - , bodyElements = toRuleBodyElement <$> _bodyConstraints context' - } - addConstants :: NaiveDatabase -> Set Constant -> NaiveDatabase addConstants db newConstants = db { constants = Set.union newConstants (constants db) } -lookupRelation0 :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation -lookupRelation0 relationName db newArity tuples = - case lookupRelation db relationName of - Nothing -> Relation relationName newArity tuples [] - Just relation -> - if _arity relation == newArity then - let newTuples = Set.union tuples $ _tuples relation - in relation { _tuples = newTuples } - else throw $ BadArityException relationName newArity - lookupRelation00 :: DatalogDB db => Text -> db -> Int -> (Relation -> Relation) -> db lookupRelation00 relationName db newArity update = @@ -114,64 +80,6 @@ withFacts = Right otherStatement -> throw $ NonFactException factText otherStatement Left ex -> throw $ CannotParseStatementException factText ex -data (DatalogDB db) => RuleContext db = RuleContext - { __relation :: Relation - , _variableNames :: [Text] - , _headEntries :: [RuleElement] - , _bodyConstraints :: [BodyConstraint] - , _db :: db - } - -digestHead :: (DatalogDB db) => db -> Relation -> Literal -> RuleContext db -digestHead db relation (Literal neg relationName terms) = - RuleContext - { __relation = relation - , _variableNames = variableNames - , _headEntries = entries' - , _bodyConstraints = [] - , _db = insertRelation (addConstants db extraConstants) relation - } - where - variableNames = nub $ extractVariableNames terms - entries' = nub $ (headTermToElement variableNames) <$> terms - extraConstants = Set.fromList $ mapMaybe extractConstant entries' where - extractConstant :: RuleElement -> Maybe Constant - extractConstant (RuleElementConstant constant) = Just constant - extractConstant _ = Nothing -digestBody :: (DatalogDB db) => Literal -> RuleContext db -> RuleContext db -digestBody (Literal neg subRelationName subTerms) context = - context { - _variableNames = variableNames - , _bodyConstraints = newConstraint : constraints - , _db = insertRelation (addConstants db constants') subRelation - } - where - db = _db context - variableNames = nub $ _variableNames context ++ extractVariableNames subTerms - newArity = length subTerms - subRelation = lookupRelation0 subRelationName (_db context) newArity Set.empty - extraConstants = mapMaybe constantFromTerm subTerms where - constantFromTerm :: Term -> Maybe Constant - constantFromTerm (Var _) = Nothing - constantFromTerm constant = Just constant - constants' = 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 - -headTermToElement :: [Text] -> Term -> RuleElement -headTermToElement variableNames (Var name) = - RuleElementVariable $ lookupVariable name variableNames -headTermToElement _ constant = RuleElementConstant constant withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) diff --git a/haskell-experiments/src/Datalog/Rules.hs b/haskell-experiments/src/Datalog/Rules.hs index 5b244f1..b343d75 100644 --- a/haskell-experiments/src/Datalog/Rules.hs +++ b/haskell-experiments/src/Datalog/Rules.hs @@ -89,3 +89,4 @@ data DatalogDBException deriving (Show) instance Exception DatalogDBException +