summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-18 17:32:15 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-18 17:32:15 +0200
commita336ca8e5564a09133e4d0a548f8b1cdcad70eee (patch)
tree870cc7e405d874c27d0353b615adfff3d21cd126
parent59dab8bf8977bef83d9194748ee3cca0823f2a16 (diff)
(schemantic datalog): implement Elementary Production rule
-rw-r--r--schemantic/datalog.scm107
1 files changed, 84 insertions, 23 deletions
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
index 1346586..2a8ee61 100644
--- a/schemantic/datalog.scm
+++ b/schemantic/datalog.scm
@@ -2,10 +2,11 @@
#:use-module (schemantic rdf)
#:use-module (oop goops)
-
+ #:use-module (ice-9 format)
#:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-43))
;; Atom
@@ -16,7 +17,9 @@
(define-method (write (self <atom>) port)
(format port "(~a~{ ~a~})"
(atom-predicate self)
- (atom-terms self)))
+ (if (vector? (atom-terms self))
+ (vector->list (atom-terms self))
+ (atom-terms self))))
(define (make-atom predicate terms)
(make <atom> #:predicate predicate #:terms terms))
@@ -24,20 +27,23 @@
(define (atom? x)
(is-a? x <atom>))
-
;; Clause
(define-class <clause> ()
(head #:init-keyword #:head #:init-value #nil #:getter clause-head)
- (body #:init-keyword #:body #:init-value #nil #:getter clause-body))
+ (body #:init-keyword #:body #:init-value #() #:getter clause-body))
(define-method (write (self <clause>) port)
(cond
- ((nil? (clause-body self))
+ ((vector-empty? (clause-body self))
(format port "~a." (clause-head self)))
(else
- (format port "~a :-~{ ~a~}." (clause-head self) (clause-body self)))))
+ (format port "~a :-~{ ~a~}."
+ (clause-head self)
+ (if (vector? (clause-body self))
+ (vector->list (clause-body self))
+ (clause-body self))))))
(define (make-clause head body)
(make <clause> #:head head #:body body))
@@ -45,13 +51,23 @@
(define (clause? x)
(is-a? x <clause>))
+(define (make-fact atom)
+ (make <clause> #:head atom))
+
+(define (fact? x)
+ (and (clause? x)
+ (nil? (clause-body x))))
+
+(define-method (fact-atom (x <clause>))
+ (clause-head x))
;; Syntax for creating clauses
-(define (syntax->atom x)
- (with-syntax
- (((predicate terms ...) x))
- #'(make-atom (quote predicate) (list terms ...))))
+(eval-when (expand load eval)
+ (define (syntax->atom x)
+ (with-syntax
+ (((predicate terms ...) x))
+ #'(make-atom (quote predicate) (vector terms ...)))))
(define-syntax :-
(lambda (x)
@@ -61,7 +77,16 @@
((head-atom (syntax->atom (syntax head)))
((body-atoms ...) (map syntax->atom (syntax (body ...)))))
(syntax
- (make-clause head-atom (list body-atoms ...))))))))
+ (make-clause head-atom (vector body-atoms ...))))))))
+
+(define-syntax !
+ (lambda (x)
+ (syntax-case x ()
+ ((_ head)
+ (with-syntax
+ ((head-atom (syntax->atom (syntax head))))
+ (syntax
+ (make-fact head-atom)))))))
;; (let ((a (lvar))
;; (b (lvar))
@@ -70,26 +95,40 @@
;; Substitution
-(define (substitute x s)
+(define-method (substitute (x <atom>) s)
+ (make-atom
+ (atom-predicate x)
+ (vector-map
+ (lambda (_ term) (substitute term s))
+ (atom-terms x))))
+
+(define-method (substitute (x <clause>) s)
+ (make-clause
+ (substitute (clause-head x) s)
+ (vector-map
+ (lambda (_ atom) (substitute atom s))
+ (clause-body x))))
+
+(define-method (substitute (x <top>) s)
(cond
((vhash-assoc x s) (cdr (vhash-assoc x s)))
(else x)))
-(define (compose s t)
+(define (substitution-compose s t)
(vhash-fold
(lambda (x y result)
(vhash-cons x (substitute y t) result))
t s))
-(define (mgu l m)
- "Returns the most general unifier for literals l and m."
+;; Returns the most general unifier for literals l and m.
+(define-method (mgu (l <atom>) (m <atom>))
(if (not (equal? (atom-predicate l) (atom-predicate m)))
;; predicates do not match. No unifier exists.
#nil
;; fold over terms in l and m
- (fold
- (lambda (tl tm s)
+ (vector-fold
+ (lambda (_ s tl tm)
(unless (nil? s)
(let ((tls (substitute tl s))
(tms (substitute tm s)))
@@ -100,11 +139,11 @@
;;
((lvar? tms)
- (compose s (vhash-cons tms tls vlist-null)))
+ (substitution-compose s (vhash-cons tms tls vlist-null)))
;;
((lvar? tls)
- (compose s (vhash-cons tls tms vlist-null)))
+ (substitution-compose s (vhash-cons tls tms vlist-null)))
;; can not unify
(else #nil)))))
@@ -114,6 +153,28 @@
(atom-terms l) (atom-terms m))))
-;; (mgu
-;; (make-atom 'hi `(1 2))
-;; (make-atom 'hi `(,(lvar) 2)))
+;; The Elemementary Production (EP) rule
+(define (produce rule facts)
+ (let ((result (vector-fold
+
+ (lambda (i rule k_i f_i)
+ (let ((s (mgu k_i f_i)))
+ (if (nil? s) #nil
+ (substitute rule s))))
+
+ rule
+
+ (clause-body rule)
+ (vector-map (lambda (_ fact) (fact-atom fact)) facts))))
+ (unless (nil? result)
+ (make-fact (clause-head result)))))
+
+(produce
+ (let ((x (lvar))) (:- (p x) (q x)))
+ (vector (! (q 1))))
+
+(produce
+ (let ((x (lvar))) (:- (p x) (q x) (s (lvar))))
+ (vector (! (q 2))
+ (! (s 3))))
+