summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-21 20:17:25 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-21 20:17:25 +0200
commit783295d27fab1dabd1a0fd008fee7fa8576a880f (patch)
tree735db251d29c2a5f262df1e997c3efa92fd5805f
parentdfcea3ff22ecfb2bdf3b32b9de7a04fa6183aedc (diff)
(schemantic datalog): normalize-head - the T algorithm from "Logic
Programming and Databases"
-rw-r--r--schemantic/datalog.scm66
-rw-r--r--schemantic/lvar.scm2
2 files changed, 66 insertions, 2 deletions
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
index 2a8ee61..4a78140 100644
--- a/schemantic/datalog.scm
+++ b/schemantic/datalog.scm
@@ -173,8 +173,72 @@
(let ((x (lvar))) (:- (p x) (q x)))
(vector (! (q 1))))
+(:- (p (lvar 'x)) (q (lvar 'x)) (s 1))
+
+(:- (p (lvar 'x)) (q (lvar 'x)))
+
(produce
- (let ((x (lvar))) (:- (p x) (q x) (s (lvar))))
+ (:- (p (lvar 'x)) (q (lvar 'x)) (s (lvar)))
(vector (! (q 2))
(! (s 3))))
+
+;; Transform to relational algebra
+
+;; The algorithm T from Section 8.3 of "Logic Programming and Databases"
+(define-method (normalize-head (clause <clause>))
+ (let* ((head (clause-head clause))
+ ;; substitute all constants in head with fresh variables
+ (case-a-substitution (vector-fold
+ (lambda (i substitution term)
+ (if (lvar? (substitute term substitution))
+ substitution
+ (vhash-cons term (lvar) substitution)))
+ vlist-null
+ (atom-terms head)))
+ ;; apply case-a-substitution to head
+ (head* (substitute head case-a-substitution))
+ ;; get the head*-terms vector to manipulate for case b
+ (head*-terms (atom-terms head*))
+ ;; replace duplicates in head
+ (case-b-substitution (cdr (vector-fold
+ (lambda (j occurences-substitution term)
+ (let ((occurences (car occurences-substitution))
+ (substitution (cdr occurences-substitution)))
+ ;; if term has already occured
+ (if (vhash-assoc term occurences)
+ (let* ( ;; position at which term first appears
+ (i (cdr (vhash-assoc term occurences)))
+ ;; create a fresh variable
+ (x (lvar)))
+ ;; replace first apperance of term with variable x
+ (vector-set! head*-terms i x)
+ (cons
+ ;; set j to the new first occurence of term
+ (vhash-cons term j (vhash-delete term occurences))
+ (vhash-cons term x substitution)))
+
+ ;; does not appear in terms yet, store the position of first appearance
+ (cons
+ (vhash-cons term j occurences)
+ substitution))))
+ (cons vlist-null vlist-null)
+ (atom-terms head*)))))
+
+ (make-clause
+ head*
+ (vector-append
+ (clause-body clause)
+ (list->vector (vlist->list
+ (vlist-map
+ (lambda (s) (make-atom '= (vector (car s) (cdr s))))
+ (vlist-append case-a-substitution case-b-substitution))))))))
+
+;; (normalize-head
+;; (:- (a 0 1) (q 2)))
+
+;; (normalize-head
+;; (:- (a (lvar 'x) (lvar 'x)) (q (lvar 'x))))
+
+;; (normalize-head
+;; (:- (a 0 0 0) (q 2)))
diff --git a/schemantic/lvar.scm b/schemantic/lvar.scm
index 5e587ce..198667c 100644
--- a/schemantic/lvar.scm
+++ b/schemantic/lvar.scm
@@ -21,7 +21,7 @@
(define-method (write (self <lvar>) port)
(if (lvar-name self)
(format port "?~a" (lvar-name self))
- (format port "<lvar ~x>" (object-address self))))
+ (format port "?~x>" (object-address self))))
(define-method (equal? (x <lvar>) (y <lvar>))
(if (and (lvar-name x) (lvar-name y))