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

lift up addRule

Browse Source
This commit is contained in:
Felix Dilke 2026-01-30 10:47:27 +00:00
parent 15f84e414d
commit 72f973c195
2 changed files with 29 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
haskell-experiments/src/Datalog/DatalogDB.hs
View File

@ -23,3 +23,4 @@ class DatalogDB db where
emptyDB :: db emptyDB :: db
lookupRelation :: db -> Text -> Maybe Relation lookupRelation :: db -> Text -> Maybe Relation
insertRelation :: db -> Relation -> db insertRelation :: db -> Relation -> db
addRule :: (Literal, [Literal]) -> db -> db

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

@ -45,6 +45,34 @@ instance DatalogDB NaiveDatabase where
relations = Map.insert (_name relation) relation (relations db) relations = Map.insert (_name relation) relation (relations db)
} }
addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
addRule (ruleHead, body) db =
NaiveDatabase relationMap' constants' where
relationName = predName ruleHead
terms = arguments ruleHead
newArity = length terms
relation = lookupRelation0 relationName db newArity Set.empty
context = digestHead db relation ruleHead
context' = foldr digestBody context body
db' = _db context'
relationMap = relations db'
relation' = appendRule relation RelationRule {
headVariables = _variableNames context'
, bodyElements = toRuleBodyElement <$> _bodyConstraints context'
}
relationMap' = Map.insert relationName relation' relationMap
constants' = constants db'
lookupRelation0 :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation
lookupRelation0 relationName db newArity tuples =
case lookupRelation db relationName of
Nothing -> Relation relationName newArity tuples []
Just relation ->
if _arity relation == newArity then
let newTuples = Set.union tuples $ _tuples relation
in relation { _tuples = newTuples }
else throw $ BadArityException relationName newArity
lookupRelation00 :: DatalogDB db => lookupRelation00 :: DatalogDB db =>
Text -> db -> Int -> (Relation -> Relation) -> db Text -> db -> Int -> (Relation -> Relation) -> db
lookupRelation00 relationName db newArity update = lookupRelation00 relationName db newArity update =
@ -57,7 +85,6 @@ lookupRelation00 relationName db newArity update =
relation relation
else throw $ BadArityException relationName newArity else throw $ BadArityException relationName newArity
lookupRelation000:: DatalogDB db => lookupRelation000:: DatalogDB db =>
Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db Text -> db -> Int -> Set [Constant] -> (Relation -> Relation) -> db
lookupRelation000 relationName db newArity tuples update = lookupRelation000 relationName db newArity tuples update =
@ -66,17 +93,6 @@ lookupRelation000 relationName db newArity tuples update =
_tuples = Set.union tuples $ _tuples relation _tuples = Set.union tuples $ _tuples relation
} }
lookupRelation0 :: DatalogDB db => Text -> db -> Int -> Set [Constant] -> Relation
lookupRelation0 relationName db newArity tuples =
case lookupRelation db relationName of
Nothing -> Relation relationName newArity tuples []
Just relation ->
if _arity relation == newArity then
let newTuples = Set.union tuples $ _tuples relation
in relation { _tuples = newTuples }
else throw $ BadArityException relationName newArity
withFacts :: [Text] -> NaiveDatabase withFacts :: [Text] -> NaiveDatabase
withFacts = withFacts =
foldr (addFact . extractFact) emptyDB foldr (addFact . extractFact) emptyDB
@ -162,24 +178,6 @@ lookupVariable varName variableNames =
Just index -> index Just index -> index
Nothing -> throw $ VariableLookupException varName variableNames Nothing -> throw $ VariableLookupException varName variableNames
addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase
addRule (ruleHead, body) db =
NaiveDatabase relationMap' constants' where
relationName = predName ruleHead
terms = arguments ruleHead
newArity = length terms
relation = lookupRelation0 relationName db newArity Set.empty
context = digestHead db relation ruleHead
context' = foldr digestBody context body
db' = _db context'
relationMap = relations db'
relation' = appendRule relation RelationRule {
headVariables = _variableNames context'
, bodyElements = toRuleBodyElement <$> _bodyConstraints context'
}
relationMap' = Map.insert relationName relation' relationMap
constants' = constants db'
query :: NaiveDatabase -> Text -> Text query :: NaiveDatabase -> Text -> Text
query db qText = query db qText =
case parseDatalog qText of case parseDatalog qText of