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

broken test: failing to look up Z

Browse Source
This commit is contained in:
Felix Dilke 2026-01-27 18:40:05 +00:00
parent 43e7d8afed
commit 95e81faa7c
2 changed files with 58 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -30,7 +30,7 @@ data NaiveDatabase = NaiveDatabase
data RuleElement -- entry occurring in a head or body relation - constant or variable data RuleElement -- entry occurring in a head or body relation - constant or variable
= RuleElementConstant Constant = RuleElementConstant Constant
| RuleElementVariable Text | RuleElementVariable Int
deriving (Show, Eq) deriving (Show, Eq)
data RuleBodyElement = RuleBodyElement data RuleBodyElement = RuleBodyElement
@ -93,14 +93,9 @@ lookupRelation relationName relationMap newArity tuples =
in Relation relationName newArity newTuples [] in Relation relationName newArity newTuples []
else throw $ BadArityException relationName newArity else throw $ BadArityException relationName newArity
data ConstraintElement -- entry occurring in a rule body constraint - constant or variable index
= ConstraintElementConstant Constant
| ConstraintElementIndex Int
deriving (Show, Eq)
data BodyConstraint = BodyConstraint data BodyConstraint = BodyConstraint
{ _relation :: Relation { _relation :: Relation
, _elements :: [ConstraintElement] , _elements :: [RuleElement]
} }
data RuleContext = RuleContext data RuleContext = RuleContext
@ -128,51 +123,65 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
digestHead db relation (Literal neg relationName terms) = digestHead db relation (Literal neg relationName terms) =
RuleContext RuleContext
{ __relation = relation { __relation = relation
, _variableNames = extractVariableNames terms , _variableNames = variableNames
, _headEntries = variables' , _headEntries = entries'
, _bodyConstraints = [] , _bodyConstraints = []
, _db = NaiveDatabase relationMap' constants' , _db = NaiveDatabase relationMap' constants'
} }
where where
variableNames = extractVariableNames terms
headTermToElement :: Term -> RuleElement
headTermToElement (Var name) =
case (elemIndex name) variableNames of
Just index -> RuleElementVariable index
Nothing -> throw $ VariableLookupException name variableNames
headTermToElement constant = RuleElementConstant constant
relationMap :: Map RelationId Relation = relations db relationMap :: Map RelationId Relation = relations db
relationMap' = Map.insert relationName relation relationMap relationMap' = Map.insert relationName relation relationMap
extraVariables = toElement <$> terms extraVariables = headTermToElement <$> terms
variables' = nub extraVariables entries' = nub extraVariables
extraConstants = mapMaybe maybeConstant variables' extraConstants = mapMaybe maybeConstant entries'
constants' = Set.union (constants db) $ 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
{ __relation = relation { __relation = relation
, _variableNames = _variableNames context , _variableNames = variableNames
, _headEntries = variables' , _headEntries = variables'
, _bodyConstraints = constraints' , _bodyConstraints = constraints'
, _db = NaiveDatabase relationMap' constants' , _db = NaiveDatabase relationMap' constants'
} }
where where
relation = __relation context relation = __relation context
variableNames = _variableNames context
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 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 = toElement <$> terms extraVariables = bodyTermToElement <$> terms
extraConstants = mapMaybe maybeConstant extraVariables extraConstants = mapMaybe maybeConstant extraVariables
variables' = nub $ _headEntries context ++ extraVariables 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 (toConstraint <$> terms) newConstraint = BodyConstraint subRelation variables'
constraints' = constraints ++ [newConstraint] constraints' = constraints ++ [newConstraint]
varIndex :: Text -> Int -- varIndex :: Text -> Int
varIndex name = -- varIndex name =
case elemIndex (RuleElementVariable name) variables' of -- case elemIndex (RuleElementVariable name) variables' of
Just index -> index -- Just index -> index
Nothing -> throw $ VariableLookupException name variables' -- Nothing -> throw $ VariableLookupException name variables'
toConstraint :: Term -> ConstraintElement -- toConstraint :: Term -> ConstraintElement
toConstraint (Var name) = ConstraintElementIndex (varIndex name) -- toConstraint (Var name) = ConstraintElementIndex (varIndex name)
toConstraint constant = ConstraintElementConstant constant -- toConstraint constant = ConstraintElementConstant constant
addRule :: (Literal, [Literal]) -> NaiveDatabase ->NaiveDatabase addRule :: (Literal, [Literal]) -> NaiveDatabase ->NaiveDatabase
addRule (ruleHead, body) db = addRule (ruleHead, body) db =
NaiveDatabase newRelationMap constants' NaiveDatabase relationMap' constants'
where where
relationName = predName ruleHead relationName = predName ruleHead
terms = arguments ruleHead terms = arguments ruleHead
@ -182,25 +191,24 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
context' = foldl digestBody context body context' = foldl digestBody context body
db' = _db context' db' = _db context'
relationMap = relations db' relationMap = relations db'
variables' = _headEntries context' -- variables' = _headEntries context'
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
newRule = newRule =
RelationRule RelationRule
{ headVariables = mapMaybe extractVarName variables' { headVariables = _variableNames context'
, bodyElements = fromBodyConstraint <$> _bodyConstraints context' , bodyElements = toRuleBodyElement <$> _bodyConstraints context'
} where
toRuleBodyElement :: BodyConstraint -> RuleBodyElement
toRuleBodyElement (BodyConstraint subRelation elements) =
RuleBodyElement {
_subRelationId = _name subRelation
, _ruleElements = elements
} }
where -- toRuleElement :: ConstraintElement -> RuleElement
fromBodyConstraint :: BodyConstraint -> RuleBodyElement -- toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
fromBodyConstraint (BodyConstraint subRelation elements) = -- toRuleElement (ConstraintElementIndex index) = variables' !! index
RuleBodyElement
{ _subRelationId = _name subRelation
, _ruleElements = toRuleElement <$> elements
}
toRuleElement :: ConstraintElement -> RuleElement
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
toRuleElement (ConstraintElementIndex index) = variables' !! index
relation' = relation' =
Relation Relation
{ _name = _name relation { _name = _name relation
@ -208,11 +216,11 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
, _tuples = _tuples relation , _tuples = _tuples relation
, _rules = newRule : _rules relation , _rules = newRule : _rules relation
} }
newRelationMap = Map.insert relationName relation' relationMap relationMap' = Map.insert relationName relation' relationMap
constants' = constants db' constants' = constants db'
toElement :: Term -> RuleElement -- toElement :: Term -> RuleElement
toElement (Var name) = RuleElementVariable name -- toElement (Var name) = RuleElementVariable name
toElement constant = RuleElementConstant constant -- toElement constant = RuleElementConstant constant
extractVariableNames :: [Term] -> [Text] extractVariableNames :: [Term] -> [Text]
extractVariableNames = mapMaybe extractVariableName where extractVariableNames = mapMaybe extractVariableName where
extractVariableName :: Term -> Maybe Text extractVariableName :: Term -> Maybe Text
@ -232,7 +240,7 @@ data NaiveDatabaseException
| NonRuleException Text Statement | NonRuleException Text Statement
| NonQueryException Text Statement | NonQueryException Text Statement
| BadArityException Text Int | BadArityException Text Int
| VariableLookupException Text [RuleElement] | VariableLookupException Text [Text]
| UnexpectedConstantException Constant | UnexpectedConstantException Constant
deriving (Show) deriving (Show)

8
haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs
View File

@ -65,15 +65,15 @@ spec = do
[ RuleBodyElement [ RuleBodyElement
{ _subRelationId = "parent" { _subRelationId = "parent"
, _ruleElements = , _ruleElements =
[ RuleElementVariable "X" [ RuleElementVariable 0
, RuleElementVariable "Z" , RuleElementVariable 2
] ]
} }
, RuleBodyElement , RuleBodyElement
{ _subRelationId = "ancestor" { _subRelationId = "ancestor"
, _ruleElements = , _ruleElements =
[ RuleElementVariable "Z" [ RuleElementVariable 2
, RuleElementVariable "Y" , RuleElementVariable 1
] ]
} }
] ]