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

refactored digestHead ; it didn't need a rule context as input

Browse Source
This commit is contained in:
Felix Dilke 2026-01-27 16:08:37 +00:00
parent 210cae7ca6
commit 7126f0e75b
1 changed files with 9 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -124,22 +124,20 @@ withFactsAndRules facts rules =
Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs) Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs)
Right otherStatement -> throw $ NonRuleException ruleText otherStatement Right otherStatement -> throw $ NonRuleException ruleText otherStatement
Left ex -> throw $ CannotParseStatementException ruleText ex Left ex -> throw $ CannotParseStatementException ruleText ex
digestHead :: RuleContext -> Literal -> RuleContext digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext
digestHead context (Literal neg relationName terms) = digestHead db relation (Literal neg relationName terms) =
RuleContext { RuleContext {
__relation = relation, __relation = relation,
_headVariables = variables', _headVariables = variables',
_bodyConstraints = _bodyConstraints context, _bodyConstraints = [],
_db = NaiveDatabase relationMap' constants' _db = NaiveDatabase relationMap' constants'
} where } where
newArity = length terms relationMap :: Map RelationId Relation = relations db
relation = __relation context
relationMap :: Map RelationId Relation = (relations (_db context))
relationMap' = Map.insert relationName relation relationMap relationMap' = Map.insert relationName relation relationMap
extraVariables = toElement <$> terms extraVariables = toElement <$> terms
extraConstants = catMaybes $ maybeConstant <$> extraVariables variables' = nub extraVariables
variables' = nub $ _headVariables context ++ extraVariables extraConstants = catMaybes $ maybeConstant <$> variables'
constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants constants' = Set.union (constants db) $ Set.fromList extraConstants
digestBody :: RuleContext -> Literal -> RuleContext digestBody :: RuleContext -> Literal -> RuleContext
digestBody context (Literal neg subRelationName terms) = digestBody context (Literal neg subRelationName terms) =
RuleContext { RuleContext {
@ -166,7 +164,6 @@ withFactsAndRules facts rules =
Just index -> index Just index -> index
Nothing -> throw $ VariableLookupException name variables' Nothing -> throw $ VariableLookupException name variables'
toConstraint :: Term -> ConstraintElement toConstraint :: Term -> ConstraintElement
-- toConstraint thing = ConstraintElementIndex 0
toConstraint (Var name) = ConstraintElementIndex (varIndex name) toConstraint (Var name) = ConstraintElementIndex (varIndex name)
toConstraint constant = ConstraintElementConstant constant toConstraint constant = ConstraintElementConstant constant
addRule :: NaiveDatabase -> (Literal, [Literal]) -> NaiveDatabase addRule :: NaiveDatabase -> (Literal, [Literal]) -> NaiveDatabase
@ -175,26 +172,12 @@ withFactsAndRules facts rules =
relationName = predName ruleHead relationName = predName ruleHead
terms = arguments ruleHead terms = arguments ruleHead
newArity = length terms newArity = length terms
relation = lookupRelation relationName (relations (_db context)) newArity Set.empty relation = lookupRelation relationName (relations db) newArity Set.empty
context = RuleContext { context' = digestHead db relation ruleHead
__relation = relation,
_headVariables = [],
_bodyConstraints = [],
_db = db
}
context' = digestHead context ruleHead
context'' = foldl digestBody context' body context'' = foldl digestBody context' body
db' = _db context'' db' = _db context''
relationMap = relations db' relationMap = relations db'
variables' = _headVariables context'' variables' = _headVariables context''
varIndex :: Text -> Int -- TODO unify with the above
varIndex name =
case elemIndex (RuleElementVariable name) variables' of
Just index -> index
Nothing -> throw $ VariableLookupException name variables'
toConstraintElement :: RuleElement -> ConstraintElement
toConstraintElement (RuleElementConstant constant) = ConstraintElementConstant constant
toConstraintElement (RuleElementVariable varName) = ConstraintElementIndex (varIndex varName)
extractVarName :: RuleElement -> Maybe Text extractVarName :: RuleElement -> Maybe Text
extractVarName (RuleElementVariable varName) = Just varName extractVarName (RuleElementVariable varName) = Just varName
extractVarName (RuleElementConstant constant) = Nothing extractVarName (RuleElementConstant constant) = Nothing