summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-26 16:33:05 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-26 16:40:51 +0200
commit96bd70d5ffbeab6c955950752b9ad60b255223ff (patch)
tree5fc31e217b641a2dc7826e289be92242017fd174
parent5e3d97626ad0ffd9c789f77bd64d529b0a4be904 (diff)
(schemantic datalog): Naive Datalog evaluation
-rw-r--r--schemantic/datalog.scm58
-rw-r--r--schemantic/datalog/relational-algebra.scm28
-rw-r--r--tests/schemantic/datalog/relational-algebra.scm26
3 files changed, 60 insertions, 52 deletions
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
index f7b04d6..92161b7 100644
--- a/schemantic/datalog.scm
+++ b/schemantic/datalog.scm
@@ -358,34 +358,40 @@
(set)
(vhash-delete (atom-predicate head) result))))
vlist-null
- (filter (compose not fact?) clauses)))
+ clauses))
+;; Algebraic Naive Evaluation (Section 9.1.1 of Logic Programming and Databases)
(define (datalog-eval clauses)
- (let* ((evaluation-context (make-evaluation-context clauses))
- (idb (sort-clauses clauses)))
- (clauses->relational-expr idb)))
-
-;; (clause->relational-expr
-;; (:- (path (lvar 'a) (lvar 'b)) (edge (lvar 'a) (lvar 'c)) (path (lvar 'c) (lvar 'c)))
-;; vlist-null)
-
-;; (push-down-a-couple-of-times
-;; (ra:make-union
-;; (vector
-;; (clause->relational-expr
-;; (! (edge 0 1))
-;; vlist-null)
-
-;; (clause->relational-expr
-;; (! (edge 1 2))
-;; vlist-null))))
-
-
-(datalog-eval
- (list
- (:- (path (lvar 'a) (lvar 'b)) (edge (lvar 'a) (lvar 'c)) (path (lvar 'c) (lvar 'c)))
- (! (edge 0 1))
- (! (edge 1 2))))
+ (let ((relational-exprs (clauses->relational-expr (sort-clauses clauses))))
+
+ (let loop ((context (make-evaluation-context clauses)))
+ (let ((context+changes?
+ (vhash-fold (λ (predicate relational-expr context+changes?)
+ (let* ((new-values (ra:evaluate (car context+changes?) relational-expr))
+ (changes? (< (set-size (vhash-ref predicate (car context+changes?)))
+ (set-size new-values))))
+ (cons (vhash-cons predicate new-values (vhash-delete predicate (car context+changes?)))
+ (or changes? (cdr context+changes?)))))
+ (cons context #f)
+ relational-exprs)))
+ (if (cdr context+changes?)
+ (loop (car context+changes?))
+ context)))))
+
+
+(set->list
+ (vhash-ref
+ 'path
+ (datalog-eval
+ (list
+ (:- (path (lvar 'x) (lvar 'y)) (path (lvar 'x) (lvar 'z)) (edge (lvar 'z) (lvar 'y)))
+ (:- (path (lvar 'x) (lvar 'y)) (edge (lvar 'x) (lvar 'y)))
+ (! (edge 0 1))
+ (! (edge 1 2))
+ (! (edge 2 4))
+ (! (edge 4 5))
+ (! (edge 2 3))
+ (! (edge 3 6))))))
;; ;; (clause-head
;; (:- (path (lvar 'a) (lvar 'b)) (edge (lvar 'a) (lvar 'c)) (path (lvar 'c) (lvar 'c))))
diff --git a/schemantic/datalog/relational-algebra.scm b/schemantic/datalog/relational-algebra.scm
index ea48d90..3a30e4b 100644
--- a/schemantic/datalog/relational-algebra.scm
+++ b/schemantic/datalog/relational-algebra.scm
@@ -22,8 +22,6 @@
evaluate
push-down
- built-in-context
-
<relation>
relation?
make-relation
@@ -102,13 +100,14 @@
;; Built-ins
-(define built-in-context
- (list
- (cons '= (lambda (attributes)
- (set (make-vector
- (vector-length attributes)
- (vector-ref attributes
- (vector-index (compose not lvar?) attributes))))))))
+
+(define (add-built-ins-to-context context)
+ (vhash-cons '= (lambda (attributes)
+ (set (make-vector
+ (vector-length attributes)
+ (vector-ref attributes
+ (vector-index (compose not lvar?) attributes)))))
+ context))
;; Relation
@@ -148,9 +147,11 @@
#:bindings (vhash-cons from-lvar to-constant (relation-bindings rel))))
(define-method (evaluate context (self <relation>))
- (let ((proc (assoc-ref (append context built-in-context)
- (relation-predicate-symbol self))))
- (proc (relation-substituted-attributes self))))
+ (let ((proc-or-set (vhash-ref (relation-predicate-symbol self)
+ (add-built-ins-to-context context))))
+ (if (procedure? proc-or-set)
+ (proc-or-set (relation-substituted-attributes self))
+ proc-or-set)))
;; Equality selection
@@ -287,8 +288,7 @@
(lambda (_ sub-rel)
(evaluate context sub-rel))
sub-exprs)))
- (compute-cartesian-product
- (vector->list sub-tuples))))
+ (compute-cartesian-product (vector->list sub-tuples))))
;; Partition the children of a cartesian-product into children that have attributes from the attribute-selection and children that do not.
(define-method (operator-partition-children (op <operator>) attribute-selection)
diff --git a/tests/schemantic/datalog/relational-algebra.scm b/tests/schemantic/datalog/relational-algebra.scm
index 26a82be..4daa0e5 100644
--- a/tests/schemantic/datalog/relational-algebra.scm
+++ b/tests/schemantic/datalog/relational-algebra.scm
@@ -35,11 +35,12 @@
(make-relation 'q (lvar 'a) (lvar 'b)))
(define context
- (list
- (cons 'p (const (set #(0 1) #(1 2) #(2 3) #(3 4) #(4 0)
- #(0 2)
- #(2 2))))
- (cons 'q (const (set #(0 "hi") #(1 "how") #(2 "are") #(3 "you") #(4 "?"))))))
+ (alist->vhash
+ (list
+ (cons 'p (const (set #(0 1) #(1 2) #(2 3) #(3 4) #(4 0)
+ #(0 2)
+ #(2 2))))
+ (cons 'q (const (set #(0 "hi") #(1 "how") #(2 "are") #(3 "you") #(4 "?")))))))
(test-assert "evaluate relation"
(eq? 7
@@ -121,13 +122,14 @@
;; built-in: equality
(define eq-context
- (list
- (cons '= (lambda (attributes)
- (set (make-vector
- (vector-length attributes)
- (vector-ref
- attributes
- (vector-index (compose not lvar?) attributes))))))))
+ (alist->vhash
+ (list
+ (cons '= (lambda (attributes)
+ (set (make-vector
+ (vector-length attributes)
+ (vector-ref
+ attributes
+ (vector-index (compose not lvar?) attributes)))))))))
(test-error "attempting to evaluate equality with no bound variables causes error"
(evaluate eq-context