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

fixed relation tuples

Browse Source
This commit is contained in:
Felix Dilke 2026-01-26 18:28:15 +00:00
parent d8a1e2f9b1
commit b8e166d867
2 changed files with 26 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -74,17 +74,19 @@ withFacts facts =
addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) =
NaiveDatabase newRelationMap newConstantSet where
newArity = length terms
newRelation = lookupRelation relationName relationMap newArity terms
newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms)
newRelationMap = Map.insert relationName newRelation relationMap
newConstantSet = Set.union constantSet $ Set.fromList terms
lookupRelation :: RelationId -> Map RelationId Relation -> Int -> [Term] -> Relation
lookupRelation relationName relationMap newArity terms =
lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation
lookupRelation relationName relationMap newArity tuples =
case Map.lookup relationName relationMap of
Nothing -> Relation relationName newArity (Set.singleton terms) []
Nothing -> Relation relationName newArity tuples []
Just relation ->
if (_arity relation == newArity)
then Relation relationName (length terms) (Set.singleton terms) []
then
let newTuples = Set.union tuples $ _tuples relation
in Relation relationName newArity newTuples []
else throw $ BadArityException relationName newArity
data ConstraintElement = -- entry occurring in a rule body constraint - constant or variable index
@ -149,7 +151,7 @@ withFactsAndRules facts rules =
} where
relation = __relation context
newArity = length terms
subRelation = lookupRelation subRelationName relationMap newArity terms
subRelation = lookupRelation subRelationName relationMap newArity Set.empty
relationMap :: Map RelationId Relation = relations (_db context)
relationMap' = Map.insert subRelationName subRelation relationMap
extraVariables = toElement <$> terms
@ -174,7 +176,7 @@ withFactsAndRules facts rules =
relationName = predName ruleHead
terms = arguments ruleHead
newArity = length terms
relation = lookupRelation relationName (relations (_db context)) newArity terms
relation = lookupRelation relationName (relations (_db context)) newArity Set.empty
context = RuleContext {
__relation = relation,
_headVariables = [],
@ -197,12 +199,6 @@ withFactsAndRules facts rules =
extractVarName :: RuleElement -> Text
extractVarName (RuleElementVariable varName) = varName
extractVarName (RuleElementConstant constant) = throw $ UnexpectedConstantException constant
-- toBodyConstraint :: (Relation, [RuleElement]) -> BodyConstraint
-- toBodyConstraint (subRelation, ruleElements) =
-- BodyConstraint {
-- _relation = subRelation,
-- _elements = toConstraintElement <$> ruleElements
-- }
newRule = RelationRule {
headVariables = extractVarName <$> variables',
body = fromBodyConstraint <$> (_bodyConstraints context'')
@ -213,10 +209,6 @@ withFactsAndRules facts rules =
toRuleElement :: ConstraintElement -> RuleElement
toRuleElement (ConstraintElementConstant constant) = RuleElementConstant constant
toRuleElement (ConstraintElementIndex index) = variables' !! index
-- input is [(Relation, [RuleElement])]
-- bodyConstraint has
-- _relation :: Relation,
-- _elements :: [ConstraintElement]
relation' = Relation {
_name = _name relation,
_arity = newArity,

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

@ -21,7 +21,7 @@ import qualified Data.Map as Map
spec :: Spec
spec = do
describe "dummy test" $ do
describe "NaiveDatabase operations" $ do
it "..." $ do
1 `shouldBe` (1 :: Int)
it "can ingest facts into relations & a universe" $ do
@ -33,7 +33,7 @@ spec = do
relations db `shouldBe`
Map.fromList [
("parent",
Relation "parent" 2 (Set.fromList ([Sym <$> ["bob", "carol"]])) [] )
Relation "parent" 2 (Set.fromList (map (Sym <$>) [["alice", "bob"], ["bob", "carol"]])) [] )
]
it "can ingest facts and rules" $ do
let db = NaiveDatabase.withFactsAndRules
@ -41,33 +41,28 @@ spec = do
, "parent(\"bob\", \"carol\")." ]
[ "ancestor(X,Y) :- parent(X,Y)."
, "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." ]
constants db `shouldBe`
(Set.fromList $ Sym <$> ["alice", "bob", "carol"])
let parentRelation = Relation {
_name = "parent",
_arity = 2,
_tuples = Set.fromList [
[Var "X",Var "Z"]
],
_tuples = Set.fromList $
map (Sym <$>) [["alice", "bob"], ["bob", "carol"]],
_rules = []
}
let ancestorRelation = Relation {
_name = "ancestor",
_arity = 2,
_tuples = Set.fromList [
[Var "Z",Var "Y"]
],
_name = "ancestor",
_tuples = Set.empty,
_rules = []
}
constants db `shouldBe`
(Set.fromList $ Sym <$> ["alice", "bob", "carol"])
relations db `shouldBe`
Map.fromList [
("ancestor",
Relation {
_arity = 2,
_name = "ancestor",
_tuples = Set.fromList [
[Var "X", Var "Y"]
],
_tuples = Set.empty,
_rules = [
RelationRule {
headVariables = [ "X", "Y", "Z" ],
@ -86,8 +81,7 @@ spec = do
]
}
]
}
),
} ),
("parent", parentRelation )
]