miniDatomic.hs

module QueryTriple where

import Control.Monad
import Data.Maybe
import Data.List
import Data.Char

-- based on https://fkettelhoit.github.io/bottom-up-datalog-js/docs/dl.html

type Ent = String

type Attr = String

type Val = String

type Name = String

type Var = String

type Expr = String -- val or var

data Fact
  = Triple Ent Attr Val
  | RuleFact Name [Expr]
  deriving (Show, Eq)

data Rule
  = Rule Name [Var] [Clause]
  deriving (Show, Eq)

data Clause
  = Pattern Expr Attr Expr
  | RuleClause Name [Expr]
  deriving (Show, Eq)

db =
  [ Triple "alice" ":name" "alice"
  , Triple "bob" ":name" "bob"
  , Triple "bill" ":name" "bill"
  , Triple "carol" ":name" "carol"
  , Triple "dennis" ":name" "dennis"
  , Triple "david" ":name" "david"
  , Triple "alice" ":parent" "bob"
  , Triple "alice" ":parent" "bill"
  , Triple "bob" ":parent" "carol"
  , Triple "carol" ":parent" "dennis"
  , Triple "carol" ":parent" "david"
  ]

rules =
  [ Rule "ancestor" ["X", "Y"]
    [ Pattern "X" ":parent" "Y"
    ]
  , Rule "ancestor" ["X", "Y"]
    [ RuleClause "ancestor" ["X", "Z"]
    , RuleClause "ancestor" ["Z", "Y"]
    ]
  , Rule "family" ["X", "Y"]
    [ RuleClause "ancestor" ["X", "Y"]
    ]
  , Rule "family" ["X", "Y"]
    [ RuleClause "family" ["Y", "X"]
    ]
  ]

q :: [Var] -> [Clause] -> [Fact] -> [Rule] -> [[(Var, Val)]]
q vars clauses facts rules = answerQuery (RuleClause "query" vars) facts (query:rules)
  where
    query = Rule "query" vars clauses

answerQuery :: Clause -> [Fact] -> [Rule] -> [[(Var, Val)]]
answerQuery clause facts rules = evalClause (buildDb facts rules) clause

buildDb :: [Fact] -> [Rule] -> [Fact]
buildDb facts rules =
  let newFacts = foldl applyRule facts rules
  in if length facts == length newFacts
    then facts
    else buildDb newFacts rules

applyRule :: [Fact] -> Rule -> [Fact]
applyRule facts rule = facts `union` ruleAsFacts facts rule

ruleAsFacts :: [Fact] -> Rule -> [Fact]
ruleAsFacts facts rule@(Rule name vars _) =
  let allBindings = generateBindings facts rule
  in map (substituteRule name vars) allBindings

substituteRule :: Name -> [Var] -> [(Var, Expr)] -> Fact
substituteRule name vars bindings = RuleFact name $ map (unifyVar bindings) vars

unifyVar :: [(Var, Expr)] -> Var -> Expr
unifyVar bindings var
  | isVariable var = maybe var id (lookup var bindings)
  | otherwise = var

isVariable :: String -> Bool
isVariable = all isUpper

generateBindings :: [Fact] -> Rule -> [[(Var, Expr)]]
generateBindings facts (Rule name vars clauses)=
  let goals = map (evalClause facts) clauses
  in foldl unifyBindingArrays (head goals) (tail goals)

unifyBindingArrays :: [[(Var, Expr)]] -> [[(Var, Expr)]] -> [[(Var, Expr)]]
unifyBindingArrays arr1 arr2 = concat $
  map (\bindings -> catMaybes $ map (unifyBindings bindings) arr2) arr1

unifyBindings :: [(Var, Expr)] -> [(Var, Expr)] -> Maybe [(Var, Expr)]
unifyBindings bindings1 bindings2 =
  let joined1 = joinMap bindings1 bindings2
      joined2 = joinMap bindings2 bindings1
  in if joined1 == joined2
    then Just joined1
    else Nothing

joinMap :: Eq a => [(a, b)] -> [(a, b)] -> [(a, b)]
joinMap [] ds = ds
joinMap ((k, v):kvs) ds = (k, v) : joinMap kvs (filter (\(k', _) -> k /= k') ds)

evalClause :: [Fact] -> Clause -> [[(Var, Expr)]]
evalClause facts clause =
  let matchedFacts = filter (unify clause) facts
  in map (asBinding clause) matchedFacts

unify :: Clause -> Fact -> Bool
unify (Pattern ent1 attr1 val1) (Triple ent2 attr2 val2) =
  all (\(k, v) -> k == v || isVariable k || isVariable v) $ zip [ent1, attr1, val1] [ent2, attr2, val2]
unify (RuleClause name1 exprs1) (RuleFact name2 exprs2) =
  all (\(k, v) -> k == v || isVariable k || isVariable v) $ zip (name1 : exprs1) (name2 : exprs2)
unify _ _ = False

asBinding :: Clause -> Fact -> [(Var, Expr)]
asBinding (Pattern ent1 attr1 val1) (Triple ent2 attr2 val2) =
  filter (\(k, _v) -> isVariable k) $ zip [ent1, attr1, val1] [ent2, attr2, val2]
asBinding (RuleClause name1 exprs1) (RuleFact name2 exprs2) =
  filter (\(k, _v) -> isVariable k) $ zip (name1 : exprs1) (name2 : exprs2)
asBinding _ _ = []