summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-09-07 14:24:39 +0200
committerpukkamustard <pukkamustard@posteo.net>2020-09-07 14:24:39 +0200
commit326ea4afab84d65eb3d7e54e6b20e0cfce79b567 (patch)
tree1a0b12080366d5d77b404852088f7bd4cbe26085
parent141b00c1267953860ef20b89ce524967d08af681 (diff)
(schemantic fragment-graph): add a fragment graph implementation for
content-addressable rdf
-rw-r--r--Makefile.am4
-rw-r--r--hall.scm8
-rw-r--r--schemantic/fragment-graph.scm168
-rw-r--r--schemantic/graph/vhash.scm1
-rw-r--r--tests/schemantic/fragment-graph.scm54
5 files changed, 230 insertions, 5 deletions
diff --git a/Makefile.am b/Makefile.am
index e4c2841..f19277c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -44,12 +44,14 @@ SOURCES = schemantic.scm \
schemantic/xsd.scm \
schemantic/rdf.scm \
schemantic/literal.scm \
+ schemantic/fragment-graph.scm \
schemantic/ns.scm
TESTS = tests/schemantic/graph/vhash.scm \
tests/schemantic/serializaton/turtle.scm \
tests/schemantic/iri.scm \
- tests/schemantic/literal.scm
+ tests/schemantic/literal.scm \
+ tests/schemantic/fragment-graph.scm
TEST_EXTENSIONS = .scm
SCM_LOG_DRIVER = \
diff --git a/hall.scm b/hall.scm
index 449bb2f..86b6f4c 100644
--- a/hall.scm
+++ b/hall.scm
@@ -28,6 +28,7 @@
(scheme-file "xsd")
(scheme-file "rdf")
(scheme-file "literal")
+ (scheme-file "fragment-graph")
(scheme-file "ns")))))
(tests ((directory
"tests"
@@ -36,10 +37,11 @@
"schemantic"
((directory "graph" ((scheme-file "vhash")))
(directory
- "serializaton"
- ((scheme-file "turtle")))
+ "serializaton"
+ ((scheme-file "turtle")))
(scheme-file "iri")
- (scheme-file "literal")))))))
+ (scheme-file "literal")
+ (scheme-file "fragment-graph")))))))
(programs ((directory "scripts" ())))
(documentation
((org-file "README")
diff --git a/schemantic/fragment-graph.scm b/schemantic/fragment-graph.scm
new file mode 100644
index 0000000..d600b76
--- /dev/null
+++ b/schemantic/fragment-graph.scm
@@ -0,0 +1,168 @@
+; SPDX-FileCopyrightText: 2020 pukkamustard <pukkamustard@posteo.net>
+;
+; SPDX-License-Identifier: GPL-3.0-or-later
+
+(define-module (schemantic fragment-graph)
+ #:use-module (schemantic rdf)
+ #:use-module (schemantic graph vhash index)
+
+ #:use-module (oop goops)
+
+ #:use-module (web uri)
+
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+
+ #:export (<fragment-graph>
+ fragment-graph?
+ make-fragment-graph
+ fragment-graph-base-subject
+
+ <fragment-reference>
+ fragment-reference?
+ make-fragment-reference
+ term->fragment-reference))
+
+
+;; Fragment Graph
+
+(define-class <fragment-graph> (<graph>)
+ (base-subject #:init-keyword #:base-subject #:accessor fragment-graph-base-subject)
+ (statements #:init-value vlist-null #:accessor statements)
+ (fragement-statements #:init-value vlist-null #:accessor fragment-statements))
+
+(define-method (write (self <fragment-graph>) port)
+ (format port "<fragment-graph ~a ~x>" (fragment-graph-base-subject self) (object-address self)))
+
+(define (make-fragment-graph base-subject)
+ (make <fragment-graph> #:base-subject base-subject))
+
+(define (fragment-graph? x)
+ (is-a? x <fragment-graph>))
+
+;; Fragment Reference
+
+(define-class <fragment-reference> (<term>)
+ (id #:init-keyword #:id #:getter fragment-reference-id))
+
+(define-method (equal? (x <fragment-reference>) (y <fragment-reference>))
+ (equal? (fragment-reference-id x) (fragment-reference-id y)))
+
+(define-method (write (self <fragment-reference>) port)
+ (format port "<fragment-reference ~a>" (fragment-reference-id self)))
+
+(define (fragment-reference? x)
+ (is-a? x <fragment-reference>))
+
+(define-method (make-fragment-reference id)
+ (make <fragment-reference> #:id id))
+
+(define (term->fragment-reference base-subject term)
+ (if (iri? term)
+ (let* ((uri (string->uri (iri-value term)))
+ (uri-without-fragment (build-uri (uri-scheme uri)
+ #:userinfo (uri-userinfo uri)
+ #:host (uri-host uri)
+ #:port (uri-port uri)
+ #:path (uri-path uri)
+ #:query (uri-query uri))))
+ (if (equal? (iri-value base-subject) (uri->string uri-without-fragment))
+ (make-fragment-reference (uri-fragment uri))
+
+ ;; not a fragment of base-subject, return as is
+ term))
+
+ ;; else just return the term
+ term))
+
+;; (term->fragment-reference (make-iri "https://example.com/")
+;; (make-iri "https://example.com/#hello"))
+
+;; (term->fragment-reference (make-iri "https://example.com")
+;; (make-literal "hi"))
+;;
+
+(define (fragment-reference->term base-subject fragment-reference)
+ (if (fragment-reference? fragment-reference)
+ (let* ((base-subject-uri (string->uri (iri-value base-subject)))
+ (uri (build-uri (uri-scheme base-subject-uri)
+ #:userinfo (uri-userinfo base-subject-uri)
+ #:host (uri-host base-subject-uri)
+ #:port (uri-port base-subject-uri)
+ #:path (uri-path base-subject-uri)
+ #:query (uri-query base-subject-uri)
+ #:fragment (fragment-reference-id fragment-reference))))
+ (make-iri (uri->string uri)))
+
+ fragment-reference))
+
+;; add a statement
+(define-method (graph-add (fg <fragment-graph>) (p <term>) (o <term>))
+ (set! (statements fg)
+ (index-add (statements fg)
+ (list (term->fragment-reference (fragment-graph-base-subject fg) p)
+ (term->fragment-reference (fragment-graph-base-subject fg) o))))
+ fg)
+
+;; add a fragment statement
+(define-method (graph-add (fg <fragment-graph>)
+ (fr <fragment-reference>)
+ (p <term>)
+ (o <term>))
+ (set! (fragment-statements fg)
+ (index-add (fragment-statements fg)
+ (list fr
+ (term->fragment-reference (fragment-graph-base-subject fg) p)
+ (term->fragment-reference (fragment-graph-base-subject fg) o)))))
+
+;; catch all method that decides if triple should be added as statement or fragment-statement
+(define-method (graph-add (fg <fragment-graph>) (s <term>) (p <term>) (o <term>))
+ (let ((fragment-reference (term->fragment-reference (fragment-graph-base-subject fg) s)))
+ (cond
+ ;; not a fragment of base-subject
+ ((not fragment-reference) fg)
+
+ ((fragment-reference? fragment-reference)
+ (if (not (fragment-reference-id fragment-reference))
+ ;; add as statement
+ (graph-add fg p o)
+ ;; add as fragment-statement
+ (graph-add fg fragment-reference p o)))))
+ fg)
+
+(define-method (graph-match (fg <fragment-graph>) (s <term>) (p <term>) (o <term>))
+ (let ((fragment-reference (term->fragment-reference (fragment-graph-base-subject fg) s)))
+ (cond
+ ;; s is not base-subject or fragment, return empty list
+ ((not fragment-reference) '())
+
+ ;; subject is a lvar match all statements and fragment statements
+ ((lvar? fragment-reference)
+ (append
+ (map (match-lambda ((p o) (make-triple
+ (fragment-graph-base-subject fg)
+ (fragment-reference->term (fragment-graph-base-subject fg) p)
+ (fragment-reference->term (fragment-graph-base-subject fg) o))))
+ (index-match (statements fg) (list p o)))
+ (map (match-lambda ((fr p o) (make-triple
+ (fragment-reference->term (fragment-graph-base-subject fg) fr)
+ (fragment-reference->term (fragment-graph-base-subject fg) p)
+ (fragment-reference->term (fragment-graph-base-subject fg) o))))
+ (index-match (fragment-statements fg) (list fragment-reference p o)))))
+
+ ((fragment-reference? fragment-reference)
+ (if (not (fragment-reference-id fragment-reference))
+ ;; s is base subject, only match statements
+ (map (match-lambda ((p o) (make-triple
+ (fragment-graph-base-subject fg)
+ (fragment-reference->term (fragment-graph-base-subject fg) p)
+ (fragment-reference->term (fragment-graph-base-subject fg) o))))
+ (index-match (statements fg) (list p o)))
+
+ ;; s is a proper fragment-reference
+ (map (match-lambda ((fr p o) (make-triple
+ (fragment-reference->term (fragment-graph-base-subject fg) fr)
+ (fragment-reference->term (fragment-graph-base-subject fg) p)
+ (fragment-reference->term (fragment-graph-base-subject fg) o))))
+ (index-match (fragment-statements fg) (list fragment-reference p o))))))))
diff --git a/schemantic/graph/vhash.scm b/schemantic/graph/vhash.scm
index a24b6f6..f4e8452 100644
--- a/schemantic/graph/vhash.scm
+++ b/schemantic/graph/vhash.scm
@@ -4,7 +4,6 @@
(define-module (schemantic graph vhash)
#:use-module (oop goops)
- #:use-module (oop goops describe)
#:use-module (schemantic rdf)
#:use-module (schemantic graph vhash index)
diff --git a/tests/schemantic/fragment-graph.scm b/tests/schemantic/fragment-graph.scm
new file mode 100644
index 0000000..1e53af1
--- /dev/null
+++ b/tests/schemantic/fragment-graph.scm
@@ -0,0 +1,54 @@
+; SPDX-FileCopyrightText: 2020 pukkamustard <pukkamustard@posteo.net>
+;
+; SPDX-License-Identifier: GPL-3.0-or-later
+
+(define-module (tests schemantic fragment-graph)
+ #:use-module (schemantic rdf)
+ #:use-module ((schemantic ns) #:select (rdf))
+ #:use-module (schemantic fragment-graph)
+
+ #:use-module (srfi srfi-64))
+
+
+(define base-subject (make-iri "http://example.com/"))
+(define-namespace ex "http://example.com/#")
+(define-namespace ex2 "http://example-two.com/#")
+
+(test-begin "fragment-reference")
+
+(test-assert "fragment-reference of self is #f"
+ (equal? (make-fragment-reference #f)
+ (term->fragment-reference base-subject base-subject)))
+
+(test-assert "can find fragment-reference"
+ (equal? (make-fragment-reference "hello")
+ (term->fragment-reference base-subject (ex "hello"))))
+
+(test-end "fragment-reference")
+
+(test-begin "fragment-graph")
+
+(test-assert "can make a fragment-graph"
+ (fragment-graph?
+ (make-fragment-graph base-subject)))
+
+(define my-fg (make-fragment-graph base-subject))
+
+(test-equal "match on empty fragment graph is emtpy"
+ '() (graph-match my-fg (make-triple (lvar) (lvar) (lvar))))
+
+(graph-add my-fg (make-triple base-subject (rdf "type") (ex "foo")))
+
+(test-assert "can add a fragment statement"
+ (equal?
+ (list (make-triple base-subject (rdf "type") (ex "foo")))
+ (graph-match my-fg (make-triple (lvar) (lvar) (lvar)))))
+
+(graph-add my-fg (make-triple (ex "bar") (rdf "type") (ex "foo")))
+
+(test-equal "can get statement and fragment statement"
+ 2 (length
+ (graph-match my-fg (make-triple (lvar) (lvar) (lvar)))))
+
+
+(test-end "fragment-graph")