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

equally broken but tidier

Browse Source
This commit is contained in:
Felix Dilke 2026-01-28 10:02:25 +00:00
parent 95e81faa7c
commit 3a5a70fbde
1 changed files with 8 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -17,7 +17,6 @@ import Data.Text (Text)
import Data.Void
import Datalog.DatalogParser (Head (HeadSingle), Literal (..), Statement (..), Term (..), parseDatalog)
import Text.Megaparsec (ParseErrorBundle)
import GHC.TypeError (ErrorMessage(Text))
data Value
= ValueInt Int
@ -66,7 +65,7 @@ emptyDB =
withFacts :: [Text] -> NaiveDatabase
withFacts facts =
foldl addFact emptyDB (extractFact <$> facts)
foldr addFact emptyDB (extractFact <$> facts)
where
extractFact :: Text -> Literal
extractFact factText =
@ -74,8 +73,8 @@ withFacts facts =
Right (Fact fact) -> fact
Right otherStatement -> throw $ NonFactException factText otherStatement
Left ex -> throw $ CannotParseStatementException factText ex
addFact :: NaiveDatabase -> Literal -> NaiveDatabase
addFact (NaiveDatabase relationMap constantSet) (Literal neg relationName terms) =
addFact :: Literal -> NaiveDatabase -> NaiveDatabase
addFact (Literal neg relationName terms) (NaiveDatabase relationMap constantSet) =
NaiveDatabase newRelationMap newConstantSet
where
newArity = length terms
@ -94,7 +93,7 @@ lookupRelation relationName relationMap newArity tuples =
else throw $ BadArityException relationName newArity
data BodyConstraint = BodyConstraint
{ _relation :: Relation
{ _subRelation :: Relation
, _elements :: [RuleElement]
}
@ -142,8 +141,8 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
entries' = nub extraVariables
extraConstants = mapMaybe maybeConstant entries'
constants' = Set.union (constants db) $ Set.fromList extraConstants
digestBody :: RuleContext -> Literal -> RuleContext
digestBody context (Literal neg subRelationName terms) =
digestBody :: Literal -> RuleContext -> RuleContext
digestBody (Literal neg subRelationName terms) context =
RuleContext
{ __relation = relation
, _variableNames = variableNames
@ -170,7 +169,7 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants
constraints = _bodyConstraints context
newConstraint = BodyConstraint subRelation variables'
constraints' = constraints ++ [newConstraint]
constraints' = newConstraint : constraints
-- varIndex :: Text -> Int
-- varIndex name =
-- case elemIndex (RuleElementVariable name) variables' of
@ -188,7 +187,7 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts)
newArity = length terms
relation = lookupRelation relationName (relations db) newArity Set.empty
context = digestHead db relation ruleHead
context' = foldl digestBody context body
context' = foldr digestBody context body
db' = _db context'
relationMap = relations db'
-- variables' = _headEntries context'