sorted out rules engine, fixed bug about adding rules

2026-01-29 15:07:14 +00:00 · 2026-01-29 15:07:14 +00:00 · 396ef53b12
commit 396ef53b12
parent 76bbd1e13e
3 changed files with 242 additions and 112 deletions
--- a/haskell-experiments/haskell-experiments.cabal
+++ b/haskell-experiments/haskell-experiments.cabal
@ -89,6 +89,8 @@ 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
--- 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 =
--- 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)