rdf.scm
| 1 | ;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu> |
| 2 | ;;;; |
| 3 | ;;;; This library is free software; you can redistribute it and/or |
| 4 | ;;;; modify it under the terms of the GNU Lesser General Public |
| 5 | ;;;; License as published by the Free Software Foundation; either |
| 6 | ;;;; version 3 of the License, or (at your option) any later version. |
| 7 | ;;;; |
| 8 | ;;;; This library is distributed in the hope that it will be useful, |
| 9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 11 | ;;;; Lesser General Public License for more details. |
| 12 | ;;;; |
| 13 | ;;;; You should have received a copy of the GNU Lesser General Public |
| 14 | ;;;; License along with this library; if not, write to the Free Software |
| 15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
| 16 | ;;;; |
| 17 | |
| 18 | (define-module (rdf entailment rdf) |
| 19 | #:use-module (ice-9 match) |
| 20 | #:use-module (rdf rdf) |
| 21 | #:use-module ((rdf entailment d) #:prefix d:) |
| 22 | #:use-module (srfi srfi-1) |
| 23 | #:export (consistent-graph? |
| 24 | entails?)) |
| 25 | |
| 26 | (define (rdf-iri name) |
| 27 | (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns#" name)) |
| 28 | |
| 29 | (define (consistent-graph? graph vocabulary) |
| 30 | (define (alist-set lst key val) |
| 31 | (match lst |
| 32 | (() (list (cons key val))) |
| 33 | (((k . v) lst ...) |
| 34 | (if (equal? k key) |
| 35 | (cons (cons key val) lst) |
| 36 | (cons (cons k v) (alist-set lst key val)))))) |
| 37 | |
| 38 | (define (compatible? types) |
| 39 | (match (filter rdf-datatype? types) |
| 40 | (() #t) |
| 41 | ((_) #t) |
| 42 | ((a b ...) |
| 43 | (and (null? (filter |
| 44 | (lambda (t) |
| 45 | (not ((rdf-vocabulary-compatible? vocabulary) a t))) |
| 46 | b)) |
| 47 | (compatible? b))))) |
| 48 | |
| 49 | (define (compatible-types? graph) |
| 50 | (let loop ((graph graph) (type-mappings '())) |
| 51 | (if (null? graph) |
| 52 | (null? |
| 53 | (filter |
| 54 | (lambda (t) |
| 55 | (not (compatible? (cdr t)))) |
| 56 | type-mappings)) |
| 57 | (let* ((t (car graph))) |
| 58 | (if (equal? (rdf-triple-predicate t) (rdf-iri "type")) |
| 59 | (loop |
| 60 | (cdr graph) |
| 61 | (alist-set type-mappings (rdf-triple-subject t) |
| 62 | (cons (rdf-triple-object t) |
| 63 | (or |
| 64 | (assoc-ref type-mappings |
| 65 | (rdf-triple-subject t)) |
| 66 | '())))) |
| 67 | (loop (cdr graph) type-mappings)))))) |
| 68 | |
| 69 | (and (d:consistent-graph? graph vocabulary) |
| 70 | (compatible-types? (augment (recognize graph vocabulary) vocabulary)))) |
| 71 | |
| 72 | ;; G entails E if E has an instance (where blank nodes are replaced by literals |
| 73 | ;; or IRIs) that is a subgraph of G. |
| 74 | ;; |
| 75 | ;; We re-use similar procedures to verifying isomorphism of graphs, but this time |
| 76 | ;; blank nodes can also map to literals and IRIs. |
| 77 | |
| 78 | ;; We follow appendix A and use a subgraph comparison (like the simple:entails? |
| 79 | ;; procedure) after augmenting the graph with additional true triples. |
| 80 | |
| 81 | (define rdf-axioms |
| 82 | (list |
| 83 | (make-rdf-triple (rdf-iri "type") (rdf-iri "type") (rdf-iri "Property")) |
| 84 | (make-rdf-triple (rdf-iri "subject") (rdf-iri "type") (rdf-iri "Property")) |
| 85 | (make-rdf-triple (rdf-iri "predicate") (rdf-iri "type") (rdf-iri "Property")) |
| 86 | (make-rdf-triple (rdf-iri "object") (rdf-iri "type") (rdf-iri "Property")) |
| 87 | (make-rdf-triple (rdf-iri "first") (rdf-iri "type") (rdf-iri "Property")) |
| 88 | (make-rdf-triple (rdf-iri "rest") (rdf-iri "type") (rdf-iri "Property")) |
| 89 | (make-rdf-triple (rdf-iri "value") (rdf-iri "type") (rdf-iri "Property")) |
| 90 | (make-rdf-triple (rdf-iri "nil") (rdf-iri "type") (rdf-iri "List")))) |
| 91 | |
| 92 | (define (rdf-axioms-container container) |
| 93 | (list |
| 94 | (make-rdf-triple |
| 95 | container (rdf-iri "type") (rdf-iri "Property")))) |
| 96 | |
| 97 | (define (rdf-container-property? p) |
| 98 | (define rdf-container-property-base (rdf-iri "_")) |
| 99 | (and (string? p) |
| 100 | (> (string-length p) (string-length rdf-container-property-base)) |
| 101 | (equal? (substring p 0 (string-length rdf-container-property-base)) |
| 102 | rdf-container-property-base) |
| 103 | (string->number |
| 104 | (substring p (string-length rdf-container-property-base))))) |
| 105 | |
| 106 | (define (rdf-container-properties g) |
| 107 | (let loop ((answer '()) (g g)) |
| 108 | (match g |
| 109 | (() (if (null? answer) (list (rdf-iri "_1")) answer)) |
| 110 | ((($ rdf-triple subject predicate object) g ...) |
| 111 | (let* ((answer (if (and (rdf-container-property? subject) |
| 112 | (not (member subject answer))) |
| 113 | (cons subject answer) |
| 114 | answer)) |
| 115 | (answer (if (and (rdf-container-property? predicate) |
| 116 | (not (member predicate answer))) |
| 117 | (cons predicate answer) |
| 118 | answer)) |
| 119 | (answer (if (and (rdf-container-property? object) |
| 120 | (not (member object answer))) |
| 121 | (cons object answer) |
| 122 | answer))) |
| 123 | (loop answer g)))))) |
| 124 | |
| 125 | (define (augment g vocabulary) |
| 126 | (let* ((g (append rdf-axioms g)) |
| 127 | (g (append |
| 128 | (append-map rdf-axioms-container (rdf-container-properties g)) |
| 129 | g))) |
| 130 | (let loop ((g (recognize g vocabulary))) |
| 131 | (let ((augment-set |
| 132 | (let loop2 ((g2 g) (augment-set '())) |
| 133 | (match g2 |
| 134 | (() augment-set) |
| 135 | ((($ rdf-triple subject predicate object) g2 ...) |
| 136 | (let ((type-triple |
| 137 | (if (and (rdf-literal? object) |
| 138 | (rdf-datatype? (rdf-literal-type object))) |
| 139 | (make-rdf-triple object (rdf-iri "type") |
| 140 | (rdf-literal-type object)) |
| 141 | #f)) |
| 142 | (property-triple |
| 143 | (make-rdf-triple predicate (rdf-iri "type") |
| 144 | (rdf-iri "Property")))) |
| 145 | (loop2 |
| 146 | g2 |
| 147 | (append |
| 148 | (if (or (not type-triple) (member type-triple g) |
| 149 | (member type-triple augment-set)) |
| 150 | '() |
| 151 | (list type-triple)) |
| 152 | (if (or (member property-triple g) |
| 153 | (member type-triple augment-set)) |
| 154 | '() |
| 155 | (list property-triple)) |
| 156 | augment-set)))))))) |
| 157 | (if (null? augment-set) |
| 158 | g |
| 159 | (loop (append (recognize augment-set vocabulary) g))))))) |
| 160 | |
| 161 | (define (entails? g e vocabulary) |
| 162 | "Return true if g entails e" |
| 163 | (let* ((g (recognize g vocabulary)) |
| 164 | (g (augment g vocabulary)) |
| 165 | (e (recognize e vocabulary))) |
| 166 | (or (not (consistent-graph? g vocabulary)) |
| 167 | (d:entails? g e vocabulary)))) |
| 168 |