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