From 396ef53b1287f71a37d139f05b4fba47a4b41ba7 Mon Sep 17 00:00:00 2001 From: Felix Dilke Date: Thu, 29 Jan 2026 15:07:14 +0000 Subject: [PATCH] sorted out rules engine, fixed bug about adding rules --- haskell-experiments/haskell-experiments.cabal | 4 +- .../src/Datalog/NaiveDatabase.hs | 213 ++++++++++-------- .../test/Test/Datalog/NaiveDatabaseSpec.hs | 137 +++++++++-- 3 files changed, 242 insertions(+), 112 deletions(-) diff --git a/haskell-experiments/haskell-experiments.cabal b/haskell-experiments/haskell-experiments.cabal index da1be79..ddbb6b4 100644 --- a/haskell-experiments/haskell-experiments.cabal +++ b/haskell-experiments/haskell-experiments.cabal @@ -89,7 +89,9 @@ library langfeatures hs-source-dirs: src exposed-modules: Ologs, SimpleParser, ArithmeticParser, Datalog.DatalogParser, Datalog.NaiveDatabase ghc-options: -Wall - + default-extensions: + OverloadedStrings + executable haskell-experiments build-depends: base, containers main-is: Main.hs diff --git a/haskell-experiments/src/Datalog/NaiveDatabase.hs b/haskell-experiments/src/Datalog/NaiveDatabase.hs index 63ae74f..0b0dc23 100644 --- a/haskell-experiments/src/Datalog/NaiveDatabase.hs +++ b/haskell-experiments/src/Datalog/NaiveDatabase.hs @@ -21,7 +21,7 @@ import Text.Megaparsec (ParseErrorBundle) data NaiveDatabase = NaiveDatabase { relations :: Map RelationId Relation , constants :: Set Constant - } + } deriving (Show, Eq) data RuleElement -- entry occurring in a head or body relation - constant or variable = RuleElementConstant Constant @@ -66,7 +66,7 @@ lookupRelation relationName relationMap newArity tuples = Just relation -> if _arity relation == newArity then let newTuples = Set.union tuples $ _tuples relation - in Relation relationName newArity newTuples [] + in relation { _tuples = newTuples } else throw $ BadArityException relationName newArity withFacts :: [Text] -> NaiveDatabase @@ -101,76 +101,91 @@ data RuleContext = RuleContext , _db :: NaiveDatabase } +appendRule :: Relation -> RelationRule -> Relation +appendRule relation rule = + relation { + _rules = rule : (_rules relation) + } + -- Relation { _name = _name relation + -- , _arity = _arity relation + -- , _tuples = _tuples relation + -- , _rules = rule : (_rules relation) + -- } + +toRuleBodyElement :: BodyConstraint -> RuleBodyElement +toRuleBodyElement (BodyConstraint subRelation elements) = + RuleBodyElement { + _subRelationId = _name subRelation + , _ruleElements = elements + } + withFactsAndRules :: [Text] -> [Text] -> NaiveDatabase withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) where - extractRule :: Text -> (Literal, [Literal]) - extractRule ruleText = - case parseDatalog ruleText of - Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs) - Right otherStatement -> throw $ NonRuleException ruleText otherStatement - Left ex -> throw $ CannotParseStatementException ruleText ex - digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext - digestHead db relation (Literal neg relationName terms) = - RuleContext - { __relation = relation - , _variableNames = variableNames - , _headEntries = entries' - , _bodyConstraints = [] - , _db = NaiveDatabase relationMap' constants' - } - where - variableNames = nub $ extractVariableNames terms - headTermToElement :: Term -> RuleElement - headTermToElement (Var name) = - RuleElementVariable $ lookupVariable name variableNames - headTermToElement constant = RuleElementConstant constant - relationMap :: Map RelationId Relation = relations db - relationMap' = Map.insert relationName relation relationMap - extraVariables = headTermToElement <$> terms - entries' = nub extraVariables - extraConstants = mapMaybe extractConstant entries' where - extractConstant :: RuleElement -> Maybe Constant - extractConstant (RuleElementConstant constant) = Just constant - extractConstant _ = Nothing - constants' = Set.union (constants db) $ Set.fromList extraConstants - digestBody :: Literal -> RuleContext -> RuleContext - digestBody (Literal neg subRelationName subTerms) context = - RuleContext - { __relation = __relation context - , _variableNames = variableNames - , _headEntries = _headEntries context - , _bodyConstraints = newConstraint : constraints - , _db = NaiveDatabase relationMap' constants' - } - where - variableNames = nub $ _variableNames context ++ extractVariableNames subTerms - newArity = length subTerms - subRelation = lookupRelation subRelationName relationMap newArity Set.empty - relationMap :: Map RelationId Relation = relations (_db context) - relationMap' = Map.insert subRelationName subRelation relationMap - extraConstants = mapMaybe constantFromTerm subTerms where - constantFromTerm :: Term -> Maybe Constant - constantFromTerm (Var _) = Nothing - constantFromTerm constant = Just constant - constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants - constraints = _bodyConstraints context - newConstraint = BodyConstraint subRelation subRuleElements where - subRuleElements = toRuleElement <$> subTerms - toRuleElement :: Term -> RuleElement - toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames - toRuleElement constant = RuleElementConstant constant - lookupVariable :: Text -> [Text] -> Int - lookupVariable varName variableNames = - case elemIndex varName variableNames of - Just index -> index - Nothing -> throw $ VariableLookupException varName variableNames +extractRule :: Text -> (Literal, [Literal]) +extractRule ruleText = + case parseDatalog ruleText of + Right (Rule (HeadSingle lhs) rhs) -> (lhs, rhs) + Right otherStatement -> throw $ NonRuleException ruleText otherStatement + Left ex -> throw $ CannotParseStatementException ruleText ex +digestHead :: NaiveDatabase -> Relation -> Literal -> RuleContext +digestHead db relation (Literal neg relationName terms) = + RuleContext + { __relation = relation + , _variableNames = variableNames + , _headEntries = entries' + , _bodyConstraints = [] + , _db = NaiveDatabase relationMap' constants' + } + where + variableNames = nub $ extractVariableNames terms + headTermToElement :: Term -> RuleElement + headTermToElement (Var name) = + RuleElementVariable $ lookupVariable name variableNames + headTermToElement constant = RuleElementConstant constant + relationMap :: Map RelationId Relation = relations db + relationMap' = Map.insert relationName relation relationMap + extraVariables = headTermToElement <$> terms + entries' = nub extraVariables + extraConstants = mapMaybe extractConstant entries' where + extractConstant :: RuleElement -> Maybe Constant + extractConstant (RuleElementConstant constant) = Just constant + extractConstant _ = Nothing + constants' = Set.union (constants db) $ Set.fromList extraConstants +digestBody :: Literal -> RuleContext -> RuleContext +digestBody (Literal neg subRelationName subTerms) context = + context { + _variableNames = variableNames + , _bodyConstraints = newConstraint : constraints + , _db = NaiveDatabase relationMap' constants' + } + where + variableNames = nub $ _variableNames context ++ extractVariableNames subTerms + newArity = length subTerms + subRelation = lookupRelation subRelationName relationMap newArity Set.empty + relationMap :: Map RelationId Relation = relations (_db context) + relationMap' = Map.insert subRelationName subRelation relationMap + extraConstants = mapMaybe constantFromTerm subTerms where + constantFromTerm :: Term -> Maybe Constant + constantFromTerm (Var _) = Nothing + constantFromTerm constant = Just constant + constants' = Set.union (constants (_db context)) $ Set.fromList extraConstants + constraints = _bodyConstraints context + newConstraint = BodyConstraint subRelation subRuleElements where + subRuleElements = toRuleElement <$> subTerms + toRuleElement :: Term -> RuleElement + toRuleElement (Var varName) = RuleElementVariable $ lookupVariable varName variableNames + toRuleElement constant = RuleElementConstant constant +lookupVariable :: Text -> [Text] -> Int +lookupVariable varName variableNames = + case elemIndex varName variableNames of + Just index -> index + Nothing -> throw $ VariableLookupException varName variableNames - addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase - addRule (ruleHead, body) db = - NaiveDatabase relationMap' constants' - where +addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase +addRule (ruleHead, body) db = + NaiveDatabase relationMap' constants' where relationName = predName ruleHead terms = arguments ruleHead newArity = length terms @@ -179,31 +194,49 @@ withFactsAndRules facts = foldr (addRule . extractRule) (withFacts facts) context' = foldr digestBody context body db' = _db context' relationMap = relations db' - relation' = - Relation - { _name = _name relation - , _arity = newArity - , _tuples = _tuples relation - , _rules = newRule : _rules relation - } where - newRule = - RelationRule - { headVariables = _variableNames context' - , bodyElements = toRuleBodyElement <$> _bodyConstraints context' - } - toRuleBodyElement :: BodyConstraint -> RuleBodyElement - toRuleBodyElement (BodyConstraint subRelation elements) = - RuleBodyElement { - _subRelationId = _name subRelation - , _ruleElements = elements - } + relation' = appendRule relation RelationRule { + headVariables = _variableNames context' + , bodyElements = toRuleBodyElement <$> _bodyConstraints context' + } relationMap' = Map.insert relationName relation' relationMap constants' = constants db' - extractVariableNames :: [Term] -> [Text] - extractVariableNames = mapMaybe extractVariableName where - extractVariableName :: Term -> Maybe Text - extractVariableName (Var name) = Just name - extractVariableName _ = Nothing +-- addRule :: (Literal, [Literal]) -> NaiveDatabase -> NaiveDatabase +-- addRule (ruleHead, body) db = +-- NaiveDatabase relationMap' constants' +-- where +-- relationName = predName ruleHead +-- terms = arguments ruleHead +-- newArity = length terms +-- relation = lookupRelation relationName (relations db) newArity Set.empty +-- context = digestHead db relation ruleHead +-- context' = foldr digestBody context body +-- db' = _db context' +-- relationMap = relations db' +-- relation' = +-- Relation +-- { _name = _name relation +-- , _arity = newArity +-- , _tuples = _tuples relation +-- , _rules = newRule : _rules relation +-- } where +-- newRule = +-- RelationRule +-- { headVariables = _variableNames context' +-- , bodyElements = toRuleBodyElement <$> _bodyConstraints context' +-- } +-- toRuleBodyElement :: BodyConstraint -> RuleBodyElement +-- toRuleBodyElement (BodyConstraint subRelation elements) = +-- RuleBodyElement { +-- _subRelationId = _name subRelation +-- , _ruleElements = elements +-- } +-- relationMap' = Map.insert relationName relation' relationMap +-- constants' = constants db' +extractVariableNames :: [Term] -> [Text] +extractVariableNames = mapMaybe extractVariableName where + extractVariableName :: Term -> Maybe Text + extractVariableName (Var name) = Just name + extractVariableName _ = Nothing query :: NaiveDatabase -> Text -> Text query db qText = diff --git a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs index 22d2b17..7d0a124 100644 --- a/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs +++ b/haskell-experiments/test/Test/Datalog/NaiveDatabaseSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -8,9 +9,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} module Test.Datalog.NaiveDatabaseSpec where @@ -25,10 +25,11 @@ spec :: Spec spec = do describe "NaiveDatabase operations" do it "can ingest facts into relations & a universe" $ do - let db = NaiveDatabase.withFacts - [ "parent(\"alice\", \"bob\")." - , "parent(\"bob\", \"carol\")." - ] + let db = + NaiveDatabase.withFacts + [ "parent(\"alice\", \"bob\")." + , "parent(\"bob\", \"carol\")." + ] constants db `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"]) relations db @@ -39,14 +40,14 @@ spec = do ) ] it "can ingest facts and rules" do - let db = NaiveDatabase.withFactsAndRules - [ "parent(\"alice\", \"bob\")." - , "parent(\"bob\", \"carol\")." - ] - [ - "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." - , "ancestor(X,Y) :- parent(X,Y)." - ] + let db = + NaiveDatabase.withFactsAndRules + [ "parent(\"alice\", \"bob\")." + , "parent(\"bob\", \"carol\")." + ] + [ "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)." + , "ancestor(X,Y) :- parent(X,Y)." + ] parentRelation = Relation { _name = "parent" @@ -56,8 +57,7 @@ spec = do map (Sym <$>) [["alice", "bob"], ["bob", "carol"]] , _rules = [] } - ancestorRule = - RelationRule + ancestorRule = RelationRule { headVariables = ["X", "Y", "Z"] , bodyElements = [ RuleBodyElement @@ -76,15 +76,26 @@ spec = do } ] } + ancestorRule2 = RelationRule + { headVariables = ["X", "Y"] + , bodyElements = + [ RuleBodyElement + { _subRelationId = "parent" + , _ruleElements = [RuleElementVariable 0, RuleElementVariable 1] + } + ] + } ancestorRelation = Relation { _arity = 2 , _name = "ancestor" , _tuples = Set.empty - , _rules = [ancestorRule] + , _rules = [ancestorRule, ancestorRule2] } + constants db `shouldBe` Set.fromList (Sym <$> ["alice", "bob", "carol"]) + relations db `shouldBe` Map.fromList [ ("ancestor", ancestorRelation) @@ -137,11 +148,95 @@ spec = do constants db `shouldBe` Set.empty + it "can ingest facts and rules with duplicate head entries" do + let db = + NaiveDatabase.withFactsAndRules + [] + ["equivalent(Q,Q) :- ."] + rule1 = + RelationRule + { headVariables = ["Q"] + , bodyElements = [] + } + + equivalentRelation = + Relation + { _arity = 2 + , _name = "equivalent" + , _tuples = Set.empty + , _rules = [rule1] + } + relations db + `shouldBe` Map.singleton "equivalent" equivalentRelation + + constants db + `shouldBe` Set.empty + + it "can ingest a theory of equivalence relations" do + let db = + NaiveDatabase.withFactsAndRules + [] + [ "equivalent(Q,Q) :- ." + , "equivalent(R,Q) :- equivalent(Q,R)." + , "equivalent(Q,S) :- equivalent(Q,R), equivalent(R,S)." + ] + rule1 = + RelationRule + { headVariables = ["Q"] + , bodyElements = [] + } + rule2 = + RelationRule + { headVariables = ["R", "Q"] + , bodyElements = + [ RuleBodyElement + { _subRelationId = "equivalent" + , _ruleElements = + [ RuleElementVariable 1 + , RuleElementVariable 0 + ] + } + ] + } + rule3 = + RelationRule + { headVariables = ["Q", "S", "R"] + , bodyElements = + [ RuleBodyElement + { _subRelationId = "equivalent" + , _ruleElements = + [ RuleElementVariable 0 + , RuleElementVariable 2 + ] + } + , RuleBodyElement + { _subRelationId = "equivalent" + , _ruleElements = + [ RuleElementVariable 2 + , RuleElementVariable 1 + ] + } + ] + } + equivalentRelation = + Relation + { _arity = 2 + , _name = "equivalent" + , _tuples = Set.empty + , _rules = [rule1, rule2, rule3] + } + relations db + `shouldBe` Map.singleton "equivalent" equivalentRelation + + constants db + `shouldBe` Set.empty + it "can do basic queries" do - let db = NaiveDatabase.withFacts - [ "parent(\"alice\", \"bob\")." - , "parent(\"bob\", \"carol\")." - ] + let db = + NaiveDatabase.withFacts + [ "parent(\"alice\", \"bob\")." + , "parent(\"bob\", \"carol\")." + ] query db "?- parent(alice,X)." `shouldBe` "#NYI" -- ideally, 'bob' (<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)