summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-23 16:44:34 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-23 16:44:34 +0200
commitf93ea7b7063952e3b51ade4e0938002ee88eec85 (patch)
tree29d00084a1537250fd89de82c1a245d48f98b9c2
parent9af721de07c840521470bd3e31c1ef23d710b9b9 (diff)
(schemantic datalog) cartesian-product
-rw-r--r--schemantic/datalog.scm52
-rw-r--r--tests/schemantic/datalog/relational-algebra.scm26
2 files changed, 75 insertions, 3 deletions
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
index 9662c02..dff364d 100644
--- a/schemantic/datalog.scm
+++ b/schemantic/datalog.scm
@@ -36,7 +36,10 @@
make-equality-selection
<projection>
- make-projection))
+ make-projection
+
+ <cartesian-product>
+ make-cartesian-product))
;; Atom
@@ -352,9 +355,52 @@
(define-class <cartesian-product> (<relational-expression>)
(sub-exprs #:init-keyword #:exprs))
+(define (make-cartesian-product exprs)
+ (make <cartesian-product> #:exprs exprs))
(define-method (write (self <cartesian-product>) port)
- (format port "<cartesian-product~{ ~a~}>" (vector->list (cartesian-product-sub-exprs self))))
+ (format port "<cartesian-product [~{~a~^ ~}]~{ ~a~}>"
+ (vector->list (relation-attributes self))
+ (vector->list (slot-ref self 'sub-exprs))))
+
+(define-method (relation-attributes (rel <cartesian-product>))
+ (vector-concatenate
+ (vector-fold-right
+ (lambda (_ result sub-expr)
+ (cons (relation-attributes sub-expr) result))
+ '()
+ (slot-ref rel 'sub-exprs))))
+
+;; NOTE this is a naive implementation that is not efficient.
+(define (compute-cartesian-product rels)
+ (cond
+ ((null? rels) rels)
+
+ ((eq? 1 (length rels)) (car rels))
+
+ (else
+ (compute-cartesian-product
+ (cons (vlist-fold
+ (lambda (tuple1 result)
+ (vlist-fold
+ (lambda (tuple2 result)
+ (vlist-cons (vector-append tuple1 tuple2) result))
+ result
+ (car (cdr rels))))
+ vlist-null
+ (car rels))
+ (drop rels 2))))))
+
+(define-method (relation-evaluate (rel <cartesian-product>))
+ (let* ((sub-exprs (slot-ref rel 'sub-exprs))
+ (sub-tuples (vector-map
+ (lambda (_ sub-rel)
+ (relation-tuples (relation-evaluate sub-rel)))
+ sub-exprs)))
+ (make-relation
+ (relation-attributes rel)
+ (compute-cartesian-product
+ (vector->list sub-tuples)))))
;; Transform clause to relational expression
@@ -440,7 +486,7 @@
(define (clause->relational-expr clause)
- (let* (;; normalize clause to remove constants and duplicate lvars in head
+ (let* ( ;; normalize clause to remove constants and duplicate lvars in head
(clause (normalize-head clause))
;; susbstitute constants in body with fresh variables
(case-a-substitution (substitute-constants (clause-body clause)))
diff --git a/tests/schemantic/datalog/relational-algebra.scm b/tests/schemantic/datalog/relational-algebra.scm
index 81fd3eb..10d6e2a 100644
--- a/tests/schemantic/datalog/relational-algebra.scm
+++ b/tests/schemantic/datalog/relational-algebra.scm
@@ -4,6 +4,7 @@
#:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-43)
#:use-module (srfi srfi-64))
(test-begin "relational-algebra")
@@ -28,6 +29,10 @@
#(0 2)
#(2 2)))))
+(define rel2
+ (make-relation (vector (lvar 'a) (lvar 'b))
+ (list->vlist
+ (list #(0 "hi") #(1 "how") #(2 "are") #(3 "you") #(4 "?")))))
(test-assert "equality-selection with lvar and constant"
(equal?
@@ -67,4 +72,25 @@
(vector (lvar 'y) (lvar 'x))
rel)))))
+;; Cartesian product
+
+(test-assert "cartesian product returns concatenated attributes"
+ (equal?
+ (vector-append (relation-attributes rel)
+ (relation-attributes rel2))
+ (relation-attributes
+ (make-cartesian-product (vector rel rel2)))))
+
+
+(test-assert "cartesian product has the right number of tuples"
+ (equal?
+
+ (* (vlist-length (relation-tuples rel))
+ (vlist-length (relation-tuples rel2)))
+
+ (vlist-length
+ (relation-tuples
+ (relation-evaluate
+ (make-cartesian-product (vector rel rel2)))))))
+
(test-end "relational-algebra")