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

adding typeclass APIs

Browse Source
This commit is contained in:
Felix Dilke 2026-01-29 17:02:27 +00:00
parent fe899bbb0c
commit 069733e474
2 changed files with 12 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -33,14 +33,16 @@ instance DatalogDB NaiveDatabase where
, constants = Set.empty -- the Herbrand universe , constants = Set.empty -- the Herbrand universe
} }
-- lookupRelation :: NaiveDatabase -> Text -> Maybe Relation -> NaiveDatabase lookupRelation :: NaiveDatabase -> Text -> Maybe Relation
-- lookupRelation = _ lookupRelation db relationName =
Map.lookup relationName $ relations db
-- insertRelation :: NaiveDatabase -> Text -> Relation -> NaiveDatabase -- insertRelation :: NaiveDatabase -> Text -> Relation -> NaiveDatabase
-- insertRelation = _ -- insertRelation = _
lookupRelation :: RelationId -> Map RelationId Relation -> Int -> Set [Term] -> Relation lookupRelation0 :: RelationId -> NaiveDatabase -> Int -> Set [Term] -> Relation
lookupRelation relationName relationMap newArity tuples = lookupRelation0 relationName db newArity tuples =
case Map.lookup relationName relationMap of case lookupRelation db relationName of
Nothing -> Relation relationName newArity tuples [] Nothing -> Relation relationName newArity tuples []
Just relation -> Just relation ->
if _arity relation == newArity then if _arity relation == newArity then
@ -59,11 +61,11 @@ withFacts =
Right otherStatement -> throw $ NonFactException factText otherStatement Right otherStatement -> throw $ NonFactException factText otherStatement
Left ex -> throw $ CannotParseStatementException factText ex Left ex -> throw $ CannotParseStatementException factText ex
addFact :: Literal -> NaiveDatabase -> NaiveDatabase addFact :: Literal -> NaiveDatabase -> NaiveDatabase
addFact (Literal neg relationName terms) (NaiveDatabase relationMap constantSet) = addFact (Literal neg relationName terms) db@(NaiveDatabase relationMap constantSet) =
NaiveDatabase newRelationMap newConstantSet NaiveDatabase newRelationMap newConstantSet
where where
newArity = length terms newArity = length terms
newRelation = lookupRelation relationName relationMap newArity (Set.singleton terms) newRelation = lookupRelation0 relationName db newArity (Set.singleton terms)
newRelationMap = Map.insert relationName newRelation relationMap newRelationMap = Map.insert relationName newRelation relationMap
newConstantSet = Set.union constantSet $ Set.fromList terms newConstantSet = Set.union constantSet $ Set.fromList terms
@ -142,7 +144,7 @@ digestBody (Literal neg subRelationName subTerms) context =
where where
variableNames = nub $ _variableNames context ++ extractVariableNames subTerms variableNames = nub $ _variableNames context ++ extractVariableNames subTerms
newArity = length subTerms newArity = length subTerms
subRelation = lookupRelation subRelationName relationMap newArity Set.empty subRelation = lookupRelation0 subRelationName (_db context) 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
extraConstants = mapMaybe constantFromTerm subTerms where extraConstants = mapMaybe constantFromTerm subTerms where
@ -168,7 +170,7 @@ addRule (ruleHead, body) db =
relationName = predName ruleHead relationName = predName ruleHead
terms = arguments ruleHead terms = arguments ruleHead
newArity = length terms newArity = length terms
relation = lookupRelation relationName (relations db) newArity Set.empty relation = lookupRelation0 relationName db newArity Set.empty
context = digestHead db relation ruleHead context = digestHead db relation ruleHead
context' = foldr digestBody context body context' = foldr digestBody context body
db' = _db context' db' = _db context'

2
haskell-experiments/src/Datalog/Rules.hs
View File

@ -49,5 +49,5 @@ type RelationId = Text
class DatalogDB db where class DatalogDB db where
emptyDB :: db emptyDB :: db
-- lookupRelation :: db -> Text -> Maybe Relation -> db lookupRelation :: db -> Text -> Maybe Relation
-- insertRelation :: db -> Text -> Relation -> db -- insertRelation :: db -> Text -> Relation -> db