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

tests green

Browse Source
This commit is contained in:
Felix Dilke 2026-01-28 11:49:21 +00:00
parent e5fc523d92
commit f2e68a455e
1 changed files with 33 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -105,10 +105,6 @@ data RuleContext = RuleContext
, _db :: NaiveDatabase , _db :: NaiveDatabase
} }
maybeConstant :: RuleElement -> Maybe Constant
maybeConstant (RuleElementConstant constant) = Just constant
maybeConstant _ = Nothing
withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase
withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
where where
@ -139,37 +135,51 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
relationMap' = Map.insert relationName relation relationMap relationMap' = Map.insert relationName relation relationMap
extraVariables = headTermToElement <$> terms extraVariables = headTermToElement <$> terms
entries' = nub extraVariables entries' = nub extraVariables
extraConstants = mapMaybe maybeConstant entries' extraConstants = mapMaybe extractConstant entries' where
extractConstant :: RuleElement -> Maybe Constant
extractConstant (RuleElementConstant constant) = Just constant
extractConstant _ = Nothing
constants' = Set.union (constants db) $ Set.fromList extraConstants constants' = Set.union (constants db) $ Set.fromList extraConstants
digestBody :: Literal -> RuleContext -> RuleContext digestBody :: Literal -> RuleContext -> RuleContext
digestBody (Literal neg subRelationName terms) context = digestBody (Literal neg subRelationName subTerms) context =
RuleContext RuleContext
{ __relation = relation { __relation = __relation context
, _variableNames = variableNames , _variableNames = variableNames
, _headEntries = variables' , _headEntries = _headEntries context
, _bodyConstraints = constraints' , _bodyConstraints = newConstraint : constraints
, _db = NaiveDatabase relationMap' constants' , _db = NaiveDatabase relationMap' constants'
} }
where where
relation = __relation context variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
variableNames = _variableNames context newArity = length subTerms
bodyTermToElement :: Term -> RuleElement
bodyTermToElement (Var name) =
case (elemIndex name) variableNames of
Just index -> RuleElementVariable index
Nothing -> throw $ VariableLookupException name variableNames
bodyTermToElement constant = RuleElementConstant constant
newArity = length terms
subRelation = lookupRelation subRelationName relationMap newArity Set.empty subRelation = lookupRelation subRelationName relationMap newArity Set.empty
relationMap :: Map RelationId Relation = relations (_db context) relationMap :: Map RelationId Relation = relations (_db context)
relationMap' = Map.insert subRelationName subRelation relationMap relationMap' = Map.insert subRelationName subRelation relationMap
extraVariables = bodyTermToElement <$> terms -- extraVariables = bodyTermToElement <$> terms where
extraConstants = mapMaybe maybeConstant extraVariables -- bodyTermToElement :: Term -> RuleElement
variables' = nub $ _headEntries context ++ extraVariables -- bodyTermToElement (Var name) =
-- case (elemIndex name) variableNames of
-- Just index -> RuleElementVariable index
-- Nothing -> throw $ VariableLookupException name variableNames
-- bodyTermToElement constant = RuleElementConstant constant
extraConstants = mapMaybe constantFromTerm subTerms where
constantFromTerm :: Term -> Maybe Constant
constantFromTerm (Var _) = Nothing
constantFromTerm constant = Just constant
-- variables' = nub $ _headEntries context ++ extraVariables
constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
constraints = _bodyConstraints context constraints = _bodyConstraints context
newConstraint = BodyConstraint subRelation variables' newConstraint = BodyConstraint subRelation subRuleElements where
constraints' = newConstraint : constraints subRuleElements = toRuleElement <$> subTerms
toRuleElement :: Term -> RuleElement
toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName
toRuleElement constant = RuleElementConstant constant
lookupVariable :: Text -> Int
lookupVariable varName =
case (elemIndex varName) variableNames of
Just index -> index
Nothing -> throw $ VariableLookupException varName variableNames
addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
addRule (ruleHead, body) db = addRule (ruleHead, body) db =
NaiveDatabase relationMap' constants' NaiveDatabase relationMap' constants'