summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-25 17:01:04 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-25 17:01:04 +0200
commit4e9a33c033f9016c9a9a497aed42c14ba2c27ae0 (patch)
treef87271cfb6c0ab192e645cd688755660b366ad39
parentc8f7068c0e865b6de4f4089a38c03a05bd0c632d (diff)
(schemantic datalog relational-algebra): unions and a whole big mess
-rw-r--r--schemantic/datalog.scm126
-rw-r--r--schemantic/datalog/relational-algebra.scm297
-rw-r--r--schemantic/datalog/vhash-set.scm2
-rw-r--r--tests/schemantic/datalog/relational-algebra.scm64
4 files changed, 386 insertions, 103 deletions
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
index 6d13203..2bb98c4 100644
--- a/schemantic/datalog.scm
+++ b/schemantic/datalog.scm
@@ -299,35 +299,113 @@
;; append the substition
(substitution (vlist-append case-a-substitution case-b-substitution))
;;
- (base-unions (ra:make-cartesian-product
- (vector-map
- (lambda (_ atom)
- (cond
- ((vhash-assoc (atom-predicate atom) relations) => cdr)
- ((equal? (atom-predicate atom) '=)
- (ra:make-equality-relation (atom-terms atom)))
- (else (ra:make-in-memory-relation
- (atom-predicate atom)
- (atom-terms atom)
- (set)))))
- body))))
+ (base-cartesian-product (ra:make-cartesian-product
+ (vector-map
+ (lambda (_ atom)
+ (cond
+ ((vhash-assoc (atom-predicate atom) relations) => cdr)
+ ((equal? (atom-predicate atom) '=)
+ (ra:make-equality-relation (atom-terms atom)))
+ (else (ra:make-in-memory-relation
+ (atom-predicate atom)
+ (atom-terms atom)
+ (set)))))
+ body))))
(ra:make-projection
(atom-terms (clause-head clause))
(vlist-fold
(lambda (s rel)
- (ra:make-equality-selection
- (list (car s) (cdr s)) rel))
- base-unions
+ (ra:make-equality-selection (car s) (cdr s) rel))
+ base-cartesian-product
substitution))))
-(clause->relational-expr
- (:- (path (lvar 'a) (lvar 'b)) (edge (lvar 'a) (lvar 'c)) (path (lvar 'c) (lvar 'c)))
- vlist-null)
-
-(clause->relational-expr
- (! (edge 0 1))
- vlist-null)
+(define* (vhash-ref key vhash #:key (default #f))
+ (cond
+ ((vhash-assoc key vhash) (cdr (vhash-assoc key vhash)))
+ (else default)))
-(normalize-head
- (:- (hello (lvar 'x) (lvar 'x)) (q (lvar 'x)) (c 1)))
+(define (vhash-map proc vhash)
+ (vhash-fold
+ (lambda (key value result)
+ (vhash-cons
+ key (proc key value)
+ result))
+ vlist-null
+ vhash))
+
+;; a hack
+(define (push-down-a-couple-of-times expression)
+ (let loop ((i 5))
+ (ra:push-down! expression)
+ (if (< 0 i)
+ (loop (1- i))))
+ expression)
+
+(define (clauses->relational-expr clauses relations)
+ (vhash-map
+ (lambda (predicate clauses)
+ (ra:make-union
+ (list->vector
+ (vlist->list
+ (vlist-map (λ (clause)
+ (clause->relational-expr clause relations))
+ clauses)))))
+ clauses))
+
+(define (sort-clauses clauses)
+ (fold
+ (lambda (clause result)
+ (let ((predicate (atom-predicate (clause-head clause))))
+ (vhash-cons
+ predicate
+ (vlist-cons clause
+ (vhash-ref predicate result #:default vlist-null))
+ (vhash-delete predicate result))))
+ vlist-null
+ clauses))
+
+(define (make-idb-relations clauses)
+ (fold
+ (lambda (clause result)
+ (let ((head (clause-head clause)))
+ (vhash-cons
+ (atom-predicate head)
+ (ra:make-in-memory-relation (atom-predicate head)
+ (atom-terms head)
+ (set))
+ (vhash-delete (atom-predicate head) result))))
+ vlist-null
+ (filter (compose not fact?) clauses)))
+
+(define (datalog-eval clauses)
+ (let* ((idb-relations (make-idb-relations clauses))
+ (idb (sort-clauses clauses)))
+ (clauses->relational-expr idb vlist-null)))
+
+;; (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))))
+
+
+;; (ra:push-down!
+;; (vhash-ref 'path
+;; (datalog-eval
+;; (list
+;; (:- (path (lvar 'a) (lvar 'b)) (edge (lvar 'a) (lvar 'c)) (path (lvar 'c) (lvar 'c)))
+;; (! (edge 0 1))
+;; (! (edge 1 2))))))
+
+;; (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 b33d2c5..cd58f0d 100644
--- a/schemantic/datalog/relational-algebra.scm
+++ b/schemantic/datalog/relational-algebra.scm
@@ -12,15 +12,15 @@
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-43)
#:export (<expression>
expression?
attributes
+ attributes-set
evaluate
- push-down
+ push-down!
<operator>
operator?
@@ -44,7 +44,11 @@
make-projection
<cartesian-product>
- make-cartesian-product))
+ make-cartesian-product
+
+ <union>
+ make-union))
+
;; Relational Algebra
;;
@@ -60,12 +64,12 @@
(define-method (attributes (expr <expression>))
#())
+(define-method (attributes-set (expr <expression>))
+ (apply set (vector->list (attributes expr))))
+
(define-method (evaluate (expr <expression>))
(set))
-(define-method (push-down (expr <expression>) (base <expression>))
- expr)
-
(define-class <operator> (<expression>)
;; sub expressions
(children #:init-keyword #:children #:accessor operator-children))
@@ -77,7 +81,8 @@
;; Relation
(define-class <relation> (<expression>)
- (attributes #:init-keyword #:attributes #:accessor attributes))
+ (attributes #:init-keyword #:attributes #:accessor attributes)
+ (bindings #:init-keyword #:bindings #:init-value vlist-null #:accessor relation-bindings))
(define (relation? x)
(is-a? x <relation>))
@@ -86,9 +91,12 @@
(format port "<relation [~{~a~^ ~}]>"
(vector->list (attributes self))))
-;; at the bottom of the tree, can not push down further.
-(define-method (push-down (rel <relation>))
- rel)
+;; Bindings are mappings from lvars to constants. This is allows
+;; equality-selections to be directly bound to the relation and be used to evaluate
+;; the relation more efficiently (or at all for built-in relations).
+;; Returns false if relation can not accept binding.
+(define-method (bind! (rel <relation>) lvar-from constant-to)
+ #f)
;; In-memory Relation
@@ -123,8 +131,7 @@
;; This is a first example of an "in-built" relation. A relation that can be
;; backed by any Scheme function.
-(define-class <equality-relation> (<relation>)
- (bindings #:init-value vlist-null #:accessor equality-relation-bindings))
+(define-class <equality-relation> (<relation>))
(define (make-equality-relation attributes)
(make <equality-relation> #:attributes attributes))
@@ -138,7 +145,7 @@
(vector-map
(lambda (_ attribute)
(vhash-ref attribute
- (equality-relation-bindings rel)
+ (relation-bindings rel)
#:default attribute))
(attributes rel)))
@@ -146,41 +153,77 @@
(format port "<equality-relation [~{~a~^ ~}]>"
(vector->list (equality-relation-substituted-attributes self))))
-(define-method (bind! (rel <equality-relation>) attribute value)
- (set! (equality-relation-bindings rel)
- (vhash-cons attribute value (equality-relation-bindings rel)))
- rel)
+(define-method (bind! (rel <equality-relation>) (from-lvar <lvar>) constant)
+ (if (set-contains? (attributes-set rel) from-lvar)
+ (begin
+ (set! (relation-bindings rel)
+ (vhash-cons from-lvar constant (relation-bindings rel)))
+ rel)
+ #f))
(define-method (evaluate (rel <equality-relation>))
(set (make-vector (vector-length (attributes rel))
- (cdar (vlist->list (equality-relation-bindings rel))))))
+ (cdar (vlist->list (relation-bindings rel))))))
;; Equality selection
(define-class <equality-selection> (<operator>)
- (operands #:init-keyword #:operands #:getter equality-selection-operands))
+ (operand1 #:init-keyword #:operand1 #:getter equality-selection-operand1)
+ (operand2 #:init-keyword #:operand2 #:getter equality-selection-operand2))
(define-method (write (self <equality-selection>) port)
- (format port "<equality-selection [~{~a~^=~}] ~a>"
- (equality-selection-operands self)
+ (format port "<equality-selection [~a=~a] ~a>"
+ (equality-selection-operand1 self)
+ (equality-selection-operand2 self)
(operator-children self)))
-(define (make-equality-selection operands child)
+(define (make-equality-selection operand1 operand2 child)
(make <equality-selection>
- #:operands operands
+ #:operand1 operand1
+ #:operand2 operand2
#:children child))
-(define-method (attributes (rel <equality-selection>))
- (attributes (operator-children rel)))
+(define-method (attributes (op <equality-selection>))
+ (attributes (operator-children op)))
+
+;; A poor man's Maybe ... TODO: use SRFI-189
+(define (just x)
+ (cons 'just x))
+
+(define (nothing)
+ (cons 'nothing '()))
+
+(define (just? maybe)
+ (eq? (car maybe) 'just))
+
+(define (nothing? maybe)
+ (eq? (car maybe) 'nothing))
+
+(define (maybe-ref maybe)
+ (cdr maybe))
+
+(define-method (equality-selection-constant-value (op <equality-selection>))
+ (cond
+ ((not (lvar? (equality-selection-operand1 op)))
+ (just (equality-selection-operand1 op)))
+
+ ((not (lvar? (equality-selection-operand2 op)))
+ (just (equality-selection-operand2 op)))
+
+ (else (nothing))))
+
+(define-method (equality-selection-lvars (op <equality-selection>))
+ (filter lvar?
+ (list (equality-selection-operand1 op)
+ (equality-selection-operand2 op))))
-(define-method (equality-selection-lvar-attributes (rel <equality-selection>))
- (apply set
- (filter lvar? (equality-selection-operands rel))))
+(equality-selection-lvars
+ (make-equality-selection (lvar 'x) (lvar 'y)
+ (make-in-memory-relation 'p (vector (lvar 'x)) (set))))
-(define-method (evaluate (rel <equality-selection>))
- (let ((sub-expr (operator-children rel))
- (attributes (attributes rel))
- (operands (equality-selection-operands rel)))
+(define-method (evaluate (op <equality-selection>))
+ (let ((sub-expr (operator-children op))
+ (attributes (attributes op)))
(set-filter
(lambda (t)
(apply equal?
@@ -190,7 +233,8 @@
(vector-ref t (vector-index (lambda (a) (equal? operand a)) attributes))
;; else operand is a constant
operand))
- operands)))
+ (list (equality-selection-operand1 op)
+ (equality-selection-operand2 op)))))
(evaluate sub-expr))))
@@ -241,13 +285,13 @@
(vector->list (attributes self))
(vector->list (operator-children self))))
-(define-method (attributes (rel <cartesian-product>))
+(define-method (attributes (op <cartesian-product>))
(vector-concatenate
(vector-fold-right
(lambda (_ result sub-expr)
(cons (attributes sub-expr) result))
'()
- (operator-children rel))))
+ (operator-children op))))
;; NOTE this is a naive implementation that is not efficient.
(define (compute-cartesian-product rels)
@@ -278,18 +322,15 @@
(compute-cartesian-product
(vector->list sub-tuples))))
-
-;; Push down
-
-(define-method (cartesian-product-partition-children (op <cartesian-product>)
- attribute-selection)
+;; 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)
(let-values (((not-in-selection in-selection)
(partition
(lambda (child)
(set-empty?
(set-intersection
attribute-selection
- (list->set (vector->list (attributes child))))))
+ (attributes-set child))))
(vector->list (operator-children op)))))
(values
(if (null? in-selection)
@@ -300,14 +341,62 @@
(make-cartesian-product (list->vector not-in-selection))))))
-(define-method (push-down (op <equality-selection>))
+;; (cartesian-product-partition-children
+;; (make-cartesian-product (vector
+;; (make-in-memory-relation 'p (vector (lvar 'a) (lvar 'b)) (set))
+;; (make-in-memory-relation 'q #(c d) (set))
+;; (make-in-memory-relation 'e #(e f) (set))))
+;; (set (lvar 'a)))
+
+;; union
+
+(define-class <union> (<operator>))
+
+(define (make-union children)
+ (make <union>
+ #:children children))
+
+(define-method (attributes (op <union>))
+ (attributes (vector-ref (operator-children op) 0)))
+
+(define-method (write (self <union>) port)
+ (format port "<union [~{~a~^ ~}]~{ ~a~}>"
+ (vector->list (attributes self))
+ (vector->list (operator-children self))))
+
+(define-method (evaluate (op <union>))
+ (vector-fold
+ (lambda (_ result child)
+ (set-union result (evaluate child)))
+ (set)
+ (operator-children op)))
+
+;; Push down
+
+(define-method (push-down! (op <operator>))
+ (set! (operator-children op)
+ (if (vector? (operator-children op))
+
+ (vector-map
+ (lambda (_ child) (push-down! child))
+ (operator-children op))
+
+ (push-down! (operator-children op))))
+ op)
+
+
+;; at the bottom of the tree, can not push down further.
+(define-method (push-down! (rel <relation>))
+ rel)
+
+(define-method (push-down! (op <equality-selection>))
(let ((child (operator-children op)))
(cond
;; selection and projection commute iff attributes referenced by selection are
((is-a? child <projection>)
(begin
(set! (operator-children op) (operator-children child))
- (set! (operator-children child) (push-down op))
+ (set! (operator-children child) (push-down! op))
child))
((is-a? child <cartesian-product>)
@@ -316,12 +405,12 @@
;; cartesian product has a single child -> the cartesian product can be removed
(begin
(set! (operator-children op) (vector-ref (operator-children child) 0))
- (push-down op))
+ (push-down! op))
;; split the cartesian product into operands that have attributes of the equality selection and such that are not affected
(let-values
(((cp-selection cp-rest)
- (cartesian-product-partition-children child (equality-selection-lvar-attributes op))))
+ (operator-partition-children child (apply set (equality-selection-lvars op)))))
(cond
@@ -335,33 +424,103 @@
(make-cartesian-product
(vector (begin
(set! (operator-children op) cp-selection)
- (push-down op))
+ (push-down! op))
cp-rest)))))))
- ((is-a? child <equality-relation>)
- (begin
- (bind! child (lvar 'x) 1)
- child))
+ ((is-a? child <union>)
+ (if (eq? 1 (vector-length (operator-children child)))
+ ;; cartesian product has a single child -> the cartesian product can be removed
+ (begin
+ (set! (operator-children op) (vector-ref (operator-children child) 0))
+ (push-down! op))
+
+ ;; split the cartesian product into operands that have attributes of the equality selection and such that are not affected
+ (let-values
+ (((cp-selection cp-rest)
+ (operator-partition-children child (apply set (equality-selection-lvars op)))))
+
+ (cond
+
+ ;; cartesian product does not contain attributes from equality selection. TODO: this means the equality-selection is not needed and should be remove.
+ ((not cp-selection) op)
- (else op))))
+ ;; cartesian product can not be split as equaity selection affects all children. TODO: this is a join and can be done more efficiently.
+ ((not cp-rest) op)
+
+ (else
+ (make-union
+ (vector (begin
+ (set! (operator-children op) cp-selection)
+ (push-down! op))
+ cp-rest)))))))
+
+ ((is-a? child <relation>)
+ (if (just? (equality-selection-constant-value op))
+ (let ((constant-to-bind (maybe-ref (equality-selection-constant-value op)))
+ (lvar-to-bind (car (equality-selection-lvars op))))
+ (if (bind! child lvar-to-bind constant-to-bind)
+ child
+ op))))
+
+ ((is-a? child <equality-selection>)
+ (begin (set! (operator-children op)
+ (push-down! child))
+ op))
-;; (push-down
-;; (make-equality-selection (list (lvar 'x) 1)
-;; (make-projection (vector (lvar 'x))
+ (else (next-method op)))))
+
+
+;; (bind!
+;; (make-in-memory-relation 'p (vector (lvar 'x) (lvar 'y)) (set))
+;; (lvar 'x) 1)
+
+;; (push-down!
+;; (make-projection (vector (lvar 'x))
+;; (make-equality-selection (lvar 'x) 1
;; (make-equality-relation (vector (lvar 'x) (lvar 'y))))))
-;; (push-down
-;; (make-equality-selection (list (lvar 'a) 1)
-;; (make-cartesian-product (vector
-;; (make-in-memory-relation 'p (vector (lvar 'a) (lvar 'b)) (set))
-;; (make-in-memory-relation 'q #(c d) (set))
-;; (make-in-memory-relation 'e #(e f) (set))))))
-
-;; (push-down
-;; (make-equality-selection (list (lvar 'x) 1)
-;; (make-cartesian-product
-;; (vector
-;; (make-in-memory-relation
-;; 'blups
-;; (vector (lvar 'x) (lvar 'y))
-;; (set))))))
+;; ;; (push-down
+;; ;; (make-equality-selection (list (lvar 'x) 1)
+;; ;; (make-projection (vector (lvar 'x))
+;; ;; (make-equality-relation (vector (lvar 'x) (lvar 'y))))))
+
+
+;; (push-down!)
+
+;; (define expr)
+;;
+;;
+
+(push-down!
+ (make-equality-selection (lvar 'a) (lvar 'c)
+ (make-cartesian-product
+ (vector
+ (make-in-memory-relation 'p (vector (lvar 'a) (lvar 'b)) (set))
+ (make-in-memory-relation 'q (vector (lvar 'c) (lvar 'd)) (set))))))
+
+(evaluate
+ (push-down!
+ (push-down!
+ (make-projection (vector (lvar 'a) (lvar 'c))
+ (make-equality-selection (lvar 'c) 2
+ (make-equality-selection (lvar 'a) 1
+ (make-cartesian-product (vector
+ (make-equality-relation (vector (lvar 'a) (lvar 'b)))
+ (make-equality-relation (vector (lvar 'c) (lvar 'd)))))))))))
+
+;; (make-projection (vector (lvar 'x) (lvar 'c))
+;; (make-equality-selection (lvar 'c) 2
+;; (make-equality-selection (lvar 'a) 1
+;; (make-cartesian-product (vector
+;; (make-equality-relation (vector (lvar 'a) (lvar 'b)))
+;; (make-equality-relation (vector (lvar 'c) (lvar 'd)))
+;; (make-equality-relation (vector (lvar 'e) (lvar 'f))))))))
+
+;; ;; (push-down
+;; ;; (make-equality-selection (list (lvar 'x) 1)
+;; ;; (make-cartesian-product
+;; ;; (vector
+;; ;; (make-in-memory-relation
+;; ;; 'blups
+;; ;; (vector (lvar 'x) (lvar 'y))
+;; ;; (set))))))
diff --git a/schemantic/datalog/vhash-set.scm b/schemantic/datalog/vhash-set.scm
index c6bd729..831535e 100644
--- a/schemantic/datalog/vhash-set.scm
+++ b/schemantic/datalog/vhash-set.scm
@@ -43,7 +43,7 @@
(define set-empty? vlist-null?)
(define (set-contains? set el)
- (vhash-assoc el set))
+ (not (not (vhash-assoc el set))))
(define set-size
vlist-length)
diff --git a/tests/schemantic/datalog/relational-algebra.scm b/tests/schemantic/datalog/relational-algebra.scm
index 4a8ae6a..e39dd67 100644
--- a/tests/schemantic/datalog/relational-algebra.scm
+++ b/tests/schemantic/datalog/relational-algebra.scm
@@ -42,30 +42,29 @@
(vector (lvar 'a) (lvar 'b))
(set #(0 "hi") #(1 "how") #(2 "are") #(3 "you") #(4 "?"))))
+;; equality selection
+
(test-assert "selection does not change attributes"
(equal?
(attributes rel1)
(attributes
- (make-equality-selection
- (list (lvar 'x) 0)
- rel1))))
+ (make-equality-selection (lvar 'x) 0
+ rel1))))
(test-assert "equality-selection with lvar and constant"
(vlist-null?
(set-difference
(set #(0 1) #(0 2))
(evaluate
- (make-equality-selection
- (list (lvar 'x) 0)
- rel1)))))
+ (make-equality-selection (lvar 'x) 0
+ rel1)))))
(test-assert "equality-selection with two lvars"
(equal?
(set #(2 2))
(evaluate
- (make-equality-selection
- (list (lvar 'x) (lvar 'y))
- rel1))))
+ (make-equality-selection (lvar 'x) (lvar 'y)
+ rel1))))
;; Projection
@@ -113,4 +112,51 @@
(evaluate
(make-cartesian-product (vector rel1 rel2))))))
+;; union
+
+(test-assert "union evaluates to set-union"
+ (eq? (+ (set-size (evaluate rel1))
+ (set-size (evaluate rel2)))
+ (set-size
+ (evaluate
+ (make-union
+ (vector rel1 rel2))))))
+
+
+;; equality-relation
+
+(test-assert "equality-relation is a relation"
+ (relation? (make-equality-relation (vector (lvar 'x) (lvar 'y)))))
+
+
+(test-error "attempting to evaluate equality with no bound variables causes error"
+ (evaluate
+ (make-equality-relation (vector (lvar 'x) (lvar 'y)))))
+
+(test-assert "evaluate equality-relation after binding onew value"
+ (equal? (set #(1 1))
+ (evaluate
+ (bind!
+ (make-equality-relation (vector (lvar 'x) (lvar 'y)))
+ (lvar 'x) 1))))
+
+;; push-down!
+
+(test-assert "push-down! binds equality-selection to equality-relation"
+ (set-contains?
+ (evaluate
+ (push-down!
+ (make-equality-selection (lvar 'x) 42
+ (make-equality-relation (vector (lvar 'x) (lvar 'y))))))
+ #(42 42)))
+
+(test-assert "push-down! pushes equality-selection past union"
+ (set-contains?
+ (evaluate
+ (push-down!
+ (make-equality-selection (lvar 'x) 0
+ (make-union
+ (vector (make-equality-relation (vector (lvar 'x) (lvar 'y))) rel2)))))
+ #(0 0)))
+
(test-end "relational-algebra")