fdilke/pyrites
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

digestBody uses the typeclass

Browse Source
This commit is contained in:
Felix Dilke 2026-01-30 12:08:29 +00:00
parent 55b12f5c00
commit e01a1ba3df
1 changed files with 5 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
haskell-experiments/src/Datalog/NaiveDatabase.hs
View File

@ -150,24 +150,23 @@ digestHead db relation (Literal neg relationName terms) =
extractConstant :: RuleElement -> Maybe Constant extractConstant :: RuleElement -> Maybe Constant
extractConstant (RuleElementConstant constant) = Just constant extractConstant (RuleElementConstant constant) = Just constant
extractConstant _ = Nothing extractConstant _ = Nothing
digestBody :: Literal -> RuleContext NaiveDatabase -> RuleContext NaiveDatabase digestBody :: forall db . (DatalogDB db) => Literal -> RuleContext db -> RuleContext db
digestBody (Literal neg subRelationName subTerms) context = digestBody (Literal neg subRelationName subTerms) context =
context { context {
_variableNames = variableNames _variableNames = variableNames
, _bodyConstraints = newConstraint : constraints , _bodyConstraints = newConstraint : constraints
, _db = NaiveDatabase relationMap' constants' , _db = insertRelation (addConstants db constants') subRelation
} }
where where
db = _db context
variableNames = nub $ _variableNames context ++ extractVariableNames subTerms variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
newArity = length subTerms newArity = length subTerms
subRelation = lookupRelation0 subRelationName (_db context) newArity Set.empty subRelation = lookupRelation0 subRelationName (_db context) newArity Set.empty
relationMap :: Map RelationId Relation = relations (_db context)
relationMap' = Map.insert subRelationName subRelation relationMap
extraConstants = mapMaybe constantFromTerm subTerms where extraConstants = mapMaybe constantFromTerm subTerms where
constantFromTerm :: Term -> Maybe Constant constantFromTerm :: Term -> Maybe Constant
constantFromTerm (Var _) = Nothing constantFromTerm (Var _) = Nothing
constantFromTerm constant = Just constant constantFromTerm constant = Just constant
constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants constants' = Set.fromList extraConstants
constraints = _bodyConstraints context constraints = _bodyConstraints context
newConstraint = BodyConstraint subRelation subRuleElements where newConstraint = BodyConstraint subRelation subRuleElements where
subRuleElements = toRuleElement <$> subTerms subRuleElements = toRuleElement <$> subTerms
@ -182,7 +181,7 @@ lookupVariable varName variableNames =
headTermToElement :: [Text] -> Term -> RuleElement headTermToElement :: [Text] -> Term -> RuleElement
headTermToElement variableNames (Var name) = headTermToElement variableNames (Var name) =
RuleElementVariable $ lookupVariable name variableNames RuleElementVariable $ lookupVariable name variableNames
headTermToElement variableNames constant = RuleElementConstant constant headTermToElement _ constant = RuleElementConstant constant
withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)