summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-18 11:37:22 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-18 11:37:22 +0200
commit59dab8bf8977bef83d9194748ee3cca0823f2a16 (patch)
treef3802e76d42336c7b009a2ad0e8d3fb43bdc35a0
parentcd23a1cb99bb141f015194ec7f4c0dca1ba683cf (diff)
(schemantic datalog): init with some nice syntax helpers and MGU algorithm
-rw-r--r--Makefile.am1
-rw-r--r--guix.scm9
-rw-r--r--hall.scm1
-rw-r--r--schemantic/datalog.scm119
4 files changed, 126 insertions, 4 deletions
diff --git a/Makefile.am b/Makefile.am
index d2ff07f..31ee4c1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -45,6 +45,7 @@ SOURCES = schemantic.scm \
schemantic/blank-node.scm \
schemantic/xsd.scm \
schemantic/rdf.scm \
+ schemantic/datalog.scm \
schemantic/fragment-graph.scm \
schemantic/fragment-graph/csexp.scm \
schemantic/fragment-graph/radix-sort.scm \
diff --git a/guix.scm b/guix.scm
index 2f10459..d528f58 100644
--- a/guix.scm
+++ b/guix.scm
@@ -17,10 +17,11 @@
(build-system gnu-build-system)
(arguments `())
(native-inputs
- `(("autoconf" ,autoconf)
- ("automake" ,automake)
- ("pkg-config" ,pkg-config)
- ("texinfo" ,texinfo)))
+ `(("autoconf" ,autoconf)
+ ("automake" ,automake)
+ ("pkg-config" ,pkg-config)
+ ("texinfo" ,texinfo)
+ ("guile-hall" ,guile-hall)))
(inputs `(("guile" ,guile-3.0)))
(propagated-inputs `(("guile-rdf" ,guile-rdf)))
(synopsis "Guile library for the Semantic Web")
diff --git a/hall.scm b/hall.scm
index d902449..4b2b999 100644
--- a/hall.scm
+++ b/hall.scm
@@ -29,6 +29,7 @@
(scheme-file "blank-node")
(scheme-file "xsd")
(scheme-file "rdf")
+ (scheme-file "datalog")
(scheme-file "fragment-graph")
(directory "fragment-graph" ((scheme-file "csexp")
(scheme-file "radix-sort")))
diff --git a/schemantic/datalog.scm b/schemantic/datalog.scm
new file mode 100644
index 0000000..1346586
--- /dev/null
+++ b/schemantic/datalog.scm
@@ -0,0 +1,119 @@
+(define-module (schemantic datalog)
+ #:use-module (schemantic rdf)
+
+ #:use-module (oop goops)
+
+ #:use-module (ice-9 vlist)
+
+ #:use-module (srfi srfi-1))
+
+;; Atom
+
+(define-class <atom> ()
+ (predicate #:init-keyword #:predicate #:getter atom-predicate)
+ (terms #:init-keyword #:terms #:getter atom-terms))
+
+(define-method (write (self <atom>) port)
+ (format port "(~a~{ ~a~})"
+ (atom-predicate self)
+ (atom-terms self)))
+
+(define (make-atom predicate terms)
+ (make <atom> #:predicate predicate #:terms terms))
+
+(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))
+
+(define-method (write (self <clause>) port)
+ (cond
+ ((nil? (clause-body self))
+ (format port "~a." (clause-head self)))
+
+ (else
+ (format port "~a :-~{ ~a~}." (clause-head self) (clause-body self)))))
+
+(define (make-clause head body)
+ (make <clause> #:head head #:body body))
+
+(define (clause? x)
+ (is-a? x <clause>))
+
+
+;; Syntax for creating clauses
+
+(define (syntax->atom x)
+ (with-syntax
+ (((predicate terms ...) x))
+ #'(make-atom (quote predicate) (list terms ...))))
+
+(define-syntax :-
+ (lambda (x)
+ (syntax-case x ()
+ ((_ head body ...)
+ (with-syntax
+ ((head-atom (syntax->atom (syntax head)))
+ ((body-atoms ...) (map syntax->atom (syntax (body ...)))))
+ (syntax
+ (make-clause head-atom (list body-atoms ...))))))))
+
+;; (let ((a (lvar))
+;; (b (lvar))
+;; (c (lvar)))
+;; (:- (path a b) (edge a c) (path c b)))
+
+;; Substitution
+
+(define (substitute x s)
+ (cond
+ ((vhash-assoc x s) (cdr (vhash-assoc x s)))
+ (else x)))
+
+(define (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."
+ (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)
+ (unless (nil? s)
+ (let ((tls (substitute tl s))
+ (tms (substitute tm s)))
+ (cond
+
+ ;; do nothing if tl and tm already unified
+ ((equal? tls tms) s)
+
+ ;;
+ ((lvar? tms)
+ (compose s (vhash-cons tms tls vlist-null)))
+
+ ;;
+ ((lvar? tls)
+ (compose s (vhash-cons tls tms vlist-null)))
+
+ ;; can not unify
+ (else #nil)))))
+
+ ;; initialize emtpy substitution
+ vlist-null
+
+ (atom-terms l) (atom-terms m))))
+
+;; (mgu
+;; (make-atom 'hi `(1 2))
+;; (make-atom 'hi `(,(lvar) 2)))