summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-25 20:27:53 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-26 08:30:59 +0200
commit5e3d97626ad0ffd9c789f77bd64d529b0a4be904 (patch)
treef6ef63fdf5448a188928a7421ed0bd89954d1985
parent4e9a33c033f9016c9a9a497aed42c14ba2c27ae0 (diff)
(schematic datalog relation-algebra): more functional push-down
-rw-r--r--schemantic/datalog.scm74
-rw-r--r--schemantic/datalog/relational-algebra.scm336
-rw-r--r--tests/schemantic/datalog/relational-algebra.scm150
3 files changed, 220 insertions, 340 deletions
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
index 2bb98c4..f7b04d6 100644
--- a/schemantic/datalog.scm
+++ b/schemantic/datalog.scm
@@ -287,7 +287,7 @@
(vlist-append case-a-substitution case-b-substitution))))))))
-(define (clause->relational-expr clause relations)
+(define (clause->relational-expr clause)
(let* ( ;; normalize clause to remove constants and duplicate lvars in head
(clause (normalize-head clause))
;; susbstitute constants in body with fresh variables
@@ -299,26 +299,19 @@
;; append the substition
(substitution (vlist-append case-a-substitution case-b-substitution))
;;
- (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))))
+ (base-cartesian-product (apply ra:make-cartesian-product
+ (vector->list (vector-map (lambda (_ atom)
+ (apply ra:make-relation
+ (cons (atom-predicate atom)
+ (vector->list (atom-terms atom)))))
+ body)))))
(ra:make-projection
(atom-terms (clause-head clause))
- (vlist-fold
- (lambda (s rel)
- (ra:make-equality-selection (car s) (cdr s) rel))
- base-cartesian-product
- substitution))))
+ (vlist-fold (lambda (s rel)
+ (ra:push-down (ra:make-equality-selection (car s) (cdr s) rel)))
+ base-cartesian-product
+ substitution))))
(define* (vhash-ref key vhash #:key (default #f))
(cond
@@ -334,23 +327,14 @@
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)
+(define (clauses->relational-expr clauses)
(vhash-map
(lambda (predicate clauses)
- (ra:make-union
- (list->vector
- (vlist->list
- (vlist-map (λ (clause)
- (clause->relational-expr clause relations))
- clauses)))))
+ (apply ra:make-union
+ (vlist->list
+ (vlist-map (λ (clause)
+ (clause->relational-expr clause))
+ clauses))))
clauses))
(define (sort-clauses clauses)
@@ -365,23 +349,21 @@
vlist-null
clauses))
-(define (make-idb-relations clauses)
+(define (make-evaluation-context 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))
+ (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))
+ (let* ((evaluation-context (make-evaluation-context clauses))
(idb (sort-clauses clauses)))
- (clauses->relational-expr idb vlist-null)))
+ (clauses->relational-expr idb)))
;; (clause->relational-expr
;; (:- (path (lvar 'a) (lvar 'b)) (edge (lvar 'a) (lvar 'c)) (path (lvar 'c) (lvar 'c)))
@@ -399,13 +381,11 @@
;; 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))))))
+(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
+;; ;; (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 cd58f0d..ea48d90 100644
--- a/schemantic/datalog/relational-algebra.scm
+++ b/schemantic/datalog/relational-algebra.scm
@@ -20,22 +20,18 @@
attributes
attributes-set
evaluate
- push-down!
+ push-down
- <operator>
- operator?
- operator-children
+ built-in-context
<relation>
relation?
- bind!
+ make-relation
+ relation-bind
- <in-memory-relation>
- in-memory-relation?
- make-in-memory-relation
-
- <equality-relation>
- make-equality-relation
+ <operator>
+ operator?
+ operator-children
<equality-selection>
make-equality-selection
@@ -49,6 +45,28 @@
<union>
make-union))
+;; Helpers
+
+(define* (vhash-ref key vhash #:key (default #f))
+ (cond
+ ((vhash-assoc key vhash) (cdr (vhash-assoc key vhash)))
+ (else default)))
+
+;; 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))
;; Relational Algebra
;;
@@ -67,7 +85,7 @@
(define-method (attributes-set (expr <expression>))
(apply set (vector->list (attributes expr))))
-(define-method (evaluate (expr <expression>))
+(define-method (evaluate context (expr <expression>))
(set))
(define-class <operator> (<expression>)
@@ -77,71 +95,37 @@
(define (operator? x)
(is-a? x <operator>))
+(define-method (operator-set-children (op <operator>) children)
+ (let ((clone (shallow-clone op)))
+ (slot-set! clone 'children children)
+ clone))
+
+;; 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))))))))
;; Relation
(define-class <relation> (<expression>)
- (attributes #:init-keyword #:attributes #:accessor attributes)
- (bindings #:init-keyword #:bindings #:init-value vlist-null #:accessor relation-bindings))
+ (predicate-symbol #:init-keyword #:predicate-symbol #:init-value #f #:getter relation-predicate-symbol)
+ (attributes #:init-keyword #:attributes #:getter relation-attributes)
+ (bindings #:init-keyword #:bindings #:init-value vlist-null #:getter relation-bindings))
-(define (relation? x)
- (is-a? x <relation>))
+(define-method (attributes (rel <relation>))
+ (relation-attributes rel))
-(define-method (write (self <relation>) port)
- (format port "<relation [~{~a~^ ~}]>"
- (vector->list (attributes self))))
-
-;; 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
-
-(define-class <in-memory-relation> (<relation>)
- (predicate-symbol #:init-keyword #:predicate-symbol
- #:init-value #f
- #:getter in-memory-relation-predicate-symbol)
- (tuples #:init-value vlist-null
- #:init-keyword #:tuples
- #:accessor in-memory-relation-tuples))
-
-(define (in-memory-relation? x)
- (is-a? x <in-memory-relation>))
-
-(define (make-in-memory-relation predicate-symbol attributes tuples)
- (make <in-memory-relation>
+(define (make-relation predicate-symbol . attributes)
+ (make <relation>
#:predicate-symbol predicate-symbol
- #:attributes attributes
- #:tuples tuples))
-
-(define-method (write (self <in-memory-relation>) port)
- (format port "<in-memory-relation ~a [~{~a~^ ~}] (~a tuples)>"
- (in-memory-relation-predicate-symbol self)
- (vector->list (attributes self))
- (set-size (in-memory-relation-tuples self))))
-
-(define-method (evaluate (self <in-memory-relation>))
- (in-memory-relation-tuples self))
-
-
-;; Equality relation
-;; 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>))
-
-(define (make-equality-relation attributes)
- (make <equality-relation> #:attributes attributes))
+ #:attributes (list->vector attributes)))
-(define* (vhash-ref x s #:key (default #f))
- (cond
- ((vhash-assoc x s) (cdr (vhash-assoc x s)))
- (else default)))
-
-(define-method (equality-relation-substituted-attributes (rel <equality-relation>))
+(define-method (relation-substituted-attributes (rel <relation>))
(vector-map
(lambda (_ attribute)
(vhash-ref attribute
@@ -149,21 +133,24 @@
#:default attribute))
(attributes rel)))
+(define (relation? x)
+ (is-a? x <relation>))
+
(define-method (write (self <relation>) port)
- (format port "<equality-relation [~{~a~^ ~}]>"
- (vector->list (equality-relation-substituted-attributes self))))
+ (format port "<relation ~a [~{~a~^ ~}]>"
+ (relation-predicate-symbol self)
+ (vector->list (relation-substituted-attributes self))))
-(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 (relation-bind (rel <relation>) (from-lvar <lvar>) to-constant)
+ (make <relation>
+ #:predicate-symbol (relation-predicate-symbol rel)
+ #:attributes (attributes rel)
+ #:bindings (vhash-cons from-lvar to-constant (relation-bindings rel))))
-(define-method (evaluate (rel <equality-relation>))
- (set (make-vector (vector-length (attributes rel))
- (cdar (vlist->list (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))))
;; Equality selection
@@ -175,32 +162,16 @@
(format port "<equality-selection [~a=~a] ~a>"
(equality-selection-operand1 self)
(equality-selection-operand2 self)
- (operator-children self)))
+ (vector-ref (operator-children self) 0)))
(define (make-equality-selection operand1 operand2 child)
(make <equality-selection>
#:operand1 operand1
#:operand2 operand2
- #:children child))
+ #:children (vector child)))
(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))
+ (attributes (vector-ref (operator-children op) 0)))
(define-method (equality-selection-constant-value (op <equality-selection>))
(cond
@@ -217,12 +188,8 @@
(list (equality-selection-operand1 op)
(equality-selection-operand2 op))))
-(equality-selection-lvars
- (make-equality-selection (lvar 'x) (lvar 'y)
- (make-in-memory-relation 'p (vector (lvar 'x)) (set))))
-
-(define-method (evaluate (op <equality-selection>))
- (let ((sub-expr (operator-children op))
+(define-method (evaluate context (op <equality-selection>))
+ (let ((sub-expr (vector-ref (operator-children op) 0))
(attributes (attributes op)))
(set-filter
(lambda (t)
@@ -235,7 +202,7 @@
operand))
(list (equality-selection-operand1 op)
(equality-selection-operand2 op)))))
- (evaluate sub-expr))))
+ (evaluate context sub-expr))))
;; Projection
@@ -246,18 +213,19 @@
(define-method (attributes (rel <projection>))
(slot-ref rel 'attributes))
-(define (make-projection attributes expr)
+(define (make-projection attributes child)
(make <projection>
#:attributes attributes
- #:children expr))
+ #:children (vector child)))
(define-method (write (self <projection>) port)
(format port "<projection [~{~a~^ ~}] ~a>"
(vector->list (attributes self))
- (operator-children self)))
+ (vector-ref (operator-children self) 0)))
-(define-method (evaluate (rel <projection>))
- (let* ((sub-expr (operator-children rel))
+
+(define-method (evaluate context (rel <projection>))
+ (let* ((sub-expr (vector-ref (operator-children rel) 0))
(sub-attributes (attributes sub-expr))
(ref-map (vector-map
(lambda (_ projection-attribute)
@@ -271,14 +239,14 @@
(lambda (i) (vector-ref tuple (vector-ref ref-map i)))
(vector-length ref-map))))
vlist-null
- (evaluate sub-expr))))
+ (evaluate context sub-expr))))
;; Cartesian product
(define-class <cartesian-product> (<operator>))
-(define (make-cartesian-product children)
- (make <cartesian-product> #:children children))
+(define (make-cartesian-product . children)
+ (make <cartesian-product> #:children (list->vector children)))
(define-method (write (self <cartesian-product>) port)
(format port "<cartesian-product [~{~a~^ ~}]~{ ~a~}>"
@@ -313,11 +281,11 @@
(car rels))
(drop rels 2))))))
-(define-method (evaluate (rel <cartesian-product>))
+(define-method (evaluate context (rel <cartesian-product>))
(let* ((sub-exprs (operator-children rel))
(sub-tuples (vector-map
(lambda (_ sub-rel)
- (evaluate sub-rel))
+ (evaluate context sub-rel))
sub-exprs)))
(compute-cartesian-product
(vector->list sub-tuples))))
@@ -335,26 +303,18 @@
(values
(if (null? in-selection)
#f
- (make-cartesian-product (list->vector in-selection)))
+ in-selection)
(if (null? not-in-selection)
#f
- (make-cartesian-product (list->vector not-in-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)))
+ not-in-selection))))
;; union
(define-class <union> (<operator>))
-(define (make-union children)
+(define (make-union . children)
(make <union>
- #:children children))
+ #:children (list->vector children)))
(define-method (attributes (op <union>))
(attributes (vector-ref (operator-children op) 0)))
@@ -364,48 +324,44 @@
(vector->list (attributes self))
(vector->list (operator-children self))))
-(define-method (evaluate (op <union>))
+(define-method (evaluate context (op <union>))
(vector-fold
(lambda (_ result child)
- (set-union result (evaluate child)))
+ (set-union result (evaluate context child)))
(set)
(operator-children op)))
;; Push down
-(define-method (push-down! (op <operator>))
+(define-method (push-down (op <operator>))
(set! (operator-children op)
(if (vector? (operator-children op))
(vector-map
- (lambda (_ child) (push-down! child))
+ (lambda (_ child) (push-down child))
(operator-children op))
- (push-down! (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>))
+(define-method (push-down (rel <relation>))
rel)
-(define-method (push-down! (op <equality-selection>))
- (let ((child (operator-children op)))
+;; NOTE I feel this is an unnecessary source of complexity and GOOPS might not be helping...
+(define-method (push-down (op <equality-selection>))
+ (let ((child (vector-ref (operator-children op) 0)))
(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))
- child))
+ (operator-set-children child
+ (push-down (operator-set-children op (operator-children child)))))
((is-a? child <cartesian-product>)
-
(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))
+ (push-down (operator-set-children op (operator-children child)))
;; split the cartesian product into operands that have attributes of the equality selection and such that are not affected
(let-values
@@ -414,25 +370,22 @@
(cond
- ;; cartesian product does not contain attributes from equality selection. TODO: this means the equality-selection is not needed and should be remove.
+ ;; cartesian product does not contain attributes from equality selection. TODO: this means the equality-selection is not needed and should be remove or an something went wrong...
((not cp-selection) 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-cartesian-product
- (vector (begin
- (set! (operator-children op) cp-selection)
- (push-down! op))
- cp-rest)))))))
+ (apply make-cartesian-product
+ (list
+ (push-down (operator-set-children op (vector (apply make-cartesian-product cp-selection))))
+ (apply make-cartesian-product cp-rest))))))))
((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))
+ (push-down (operator-set-children op (operator-children child)))
;; split the cartesian product into operands that have attributes of the equality selection and such that are not affected
(let-values
@@ -441,86 +394,25 @@
(cond
- ;; cartesian product does not contain attributes from equality selection. TODO: this means the equality-selection is not needed and should be remove.
+ ;; cartesian product does not contain attributes from equality selection. TODO: this means the equality-selection is not needed and should be remove or an something went wrong...
((not cp-selection) 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)))))))
+ (apply make-union
+ (list
+ (push-down (operator-set-children op (vector (apply make-union cp-selection))))
+ (apply make-union 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))))
+ (relation-bind child lvar-to-bind constant-to-bind))))
((is-a? child <equality-selection>)
- (begin (set! (operator-children op)
- (push-down! child))
- op))
+ (operator-set-children op (vector (push-down child))))
(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 '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/tests/schemantic/datalog/relational-algebra.scm b/tests/schemantic/datalog/relational-algebra.scm
index e39dd67..26a82be 100644
--- a/tests/schemantic/datalog/relational-algebra.scm
+++ b/tests/schemantic/datalog/relational-algebra.scm
@@ -16,69 +16,69 @@
(test-assert "make-relation"
(relation?
- (make-in-memory-relation
- 'p
- (vector (lvar 'x) (lvar 'y)) vlist-null)))
+ (make-relation 'p (lvar 'x) (lvar 'y))))
(test-assert "get attributes from relation"
(equal? (vector (lvar 'x) (lvar 'y))
(attributes
- (make-in-memory-relation 'p (vector (lvar 'x) (lvar 'y)) vlist-null))))
+ (make-relation 'p (lvar 'x) (lvar 'y)))))
;; Relational Algebra expressions
;; in-memory-relations for testing
-(define rel1
- (make-in-memory-relation 'p
- (vector (lvar 'x) (lvar 'y))
- (set #(0 1) #(1 2) #(2 3) #(3 4) #(4 0)
- #(0 2)
- #(2 2))))
-
-(define rel2
- (make-in-memory-relation 'q
- (vector (lvar 'a) (lvar 'b))
- (set #(0 "hi") #(1 "how") #(2 "are") #(3 "you") #(4 "?"))))
+(define rel-p
+ (make-relation 'p (lvar 'x) (lvar 'y)))
+
+(define rel-q
+ (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 "?"))))))
+
+(test-assert "evaluate relation"
+ (eq? 7
+ (set-size
+ (evaluate context rel-p))))
;; equality selection
-(test-assert "selection does not change attributes"
- (equal?
- (attributes rel1)
- (attributes
- (make-equality-selection (lvar 'x) 0
- rel1))))
+(test-assert "selection does not change attributes")
+(equal?
+ (attributes rel-p))
+(attributes
+ (make-equality-selection (lvar 'x) 0 rel-p))
(test-assert "equality-selection with lvar and constant"
(vlist-null?
(set-difference
(set #(0 1) #(0 2))
- (evaluate
- (make-equality-selection (lvar 'x) 0
- rel1)))))
+ (evaluate context
+ (make-equality-selection (lvar 'x) 0 rel-p)))))
(test-assert "equality-selection with two lvars"
(equal?
(set #(2 2))
- (evaluate
- (make-equality-selection (lvar 'x) (lvar 'y)
- rel1))))
+ (evaluate context
+ (make-equality-selection (lvar 'x) (lvar 'y)
+ rel-p))))
;; Projection
(test-assert "project to a single attribute"
- (vlist-null?
+ (set-empty?
(set-difference
(set-fold (lambda (tuple result)
(set-adjoin result (vector (vector-ref tuple 0))))
vlist-null
- (evaluate rel1))
- (evaluate
- (make-projection
- (vector (lvar 'x))
- rel1)))))
+ (evaluate context rel-p))
+ (evaluate context
+ (make-projection (vector (lvar 'x)) rel-p)))))
(test-assert "project to two attributes (reverse order)"
(vlist-null?
@@ -86,77 +86,85 @@
(set-fold (lambda (tuple result)
(set-adjoin result (list->vector (reverse (vector->list tuple)))))
vlist-null
- (evaluate rel1))
- (evaluate
- (make-projection
- (vector (lvar 'y) (lvar 'x))
- rel1)))))
+ (evaluate context rel-p))
+ (evaluate context
+ (make-projection (vector (lvar 'y) (lvar 'x)) rel-p)))))
;; Cartesian product
(test-assert "cartesian product returns concatenated attributes"
(equal?
- (vector-append (attributes rel1)
- (attributes rel2))
- (attributes
- (make-cartesian-product (vector rel1 rel2)))))
+ (vector-append (attributes rel-p)
+ (attributes rel-q))
+ (attributes (make-cartesian-product rel-p rel-q))))
(test-assert "cartesian product has the right number of tuples"
(equal?
- (* (set-size (evaluate rel1))
- (set-size (evaluate rel2)))
+ (* (set-size (evaluate context rel-p))
+ (set-size (evaluate context rel-q)))
(set-size
- (evaluate
- (make-cartesian-product (vector rel1 rel2))))))
+ (evaluate context
+ (make-cartesian-product rel-p rel-q)))))
;; union
(test-assert "union evaluates to set-union"
- (eq? (+ (set-size (evaluate rel1))
- (set-size (evaluate rel2)))
+ (eq? (+ (set-size (evaluate context rel-p))
+ (set-size (evaluate context rel-q)))
(set-size
- (evaluate
- (make-union
- (vector rel1 rel2))))))
-
+ (evaluate context (make-union rel-p rel-q)))))
-;; equality-relation
-(test-assert "equality-relation is a relation"
- (relation? (make-equality-relation (vector (lvar 'x) (lvar 'y)))))
+;; 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))))))))
(test-error "attempting to evaluate equality with no bound variables causes error"
- (evaluate
- (make-equality-relation (vector (lvar 'x) (lvar 'y)))))
+ (evaluate eq-context
+ (make-relation '= (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))))
+ (evaluate eq-context
+ (relation-bind
+ (make-relation '= (lvar 'x) (lvar 'y))
+ (lvar 'x) 1))))
-;; push-down!
+;; 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))))))
+ (evaluate eq-context
+ (push-down
+ (make-equality-selection (lvar 'x) 42 (make-relation '= (lvar 'x) (lvar 'y)))))
#(42 42)))
+(test-assert "push-down goes past and removes cartesian-product with a single child"
+ (set-contains?
+ (evaluate eq-context
+ (push-down
+ (make-equality-selection (lvar 'x) 0
+ (make-cartesian-product
+ (make-relation '= (lvar 'x) (lvar 'y))))))
+ #(0 0)))
+
(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)))))
+ (evaluate context
+ (push-down
+ (make-equality-selection (lvar 'x) 0
+ (make-union
+ (make-relation '= (lvar 'x) (lvar 'y)) rel-q))))
#(0 0)))
(test-end "relational-algebra")