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) |
| 30 | (define (non-overlapping-types? graph) |
| 31 | (let loop ((graph graph) (type-mappings '())) |
| 32 | (if (null? graph) |
| 33 | #t |
| 34 | (let* ((t (car graph))) |
| 35 | (if (equal? (rdf-triple-predicate t) (rdf-iri "type")) |
| 36 | (if (assoc-ref type-mappings (rdf-triple-subject t)) |
| 37 | #f |
| 38 | (loop (cdr graph) |
| 39 | (cons |
| 40 | (cons (rdf-triple-subject t) (rdf-triple-object t)) |
| 41 | type-mappings))) |
| 42 | (loop (cdr graph) type-mappings)))))) |
| 43 | (and (d:consistent-graph? graph) |
| 44 | (non-overlapping-types? graph))) |
| 45 | |
| 46 | ;; G entails E if E has an instance (where blank nodes are replaced by literals |
| 47 | ;; or IRIs) that is a subgraph of G. |
| 48 | ;; |
| 49 | ;; We re-use similar procedures to verifying isomorphism of graphs, but this time |
| 50 | ;; blank nodes can also map to literals and IRIs. |
| 51 | |
| 52 | ;; We follow appendix A and use a subgraph comparison (like the simple:entails? |
| 53 | ;; procedure) after augmenting the graph with additional true triples. |
| 54 | |
| 55 | (define rdf-axioms |
| 56 | (list |
| 57 | (make-rdf-triple (rdf-iri "type") (rdf-iri "type") (rdf-iri "Property")) |
| 58 | (make-rdf-triple (rdf-iri "subject") (rdf-iri "type") (rdf-iri "Property")) |
| 59 | (make-rdf-triple (rdf-iri "predicate") (rdf-iri "type") (rdf-iri "Property")) |
| 60 | (make-rdf-triple (rdf-iri "object") (rdf-iri "type") (rdf-iri "Property")) |
| 61 | (make-rdf-triple (rdf-iri "first") (rdf-iri "type") (rdf-iri "Property")) |
| 62 | (make-rdf-triple (rdf-iri "rest") (rdf-iri "type") (rdf-iri "Property")) |
| 63 | (make-rdf-triple (rdf-iri "value") (rdf-iri "type") (rdf-iri "Property")) |
| 64 | (make-rdf-triple (rdf-iri "nil") (rdf-iri "type") (rdf-iri "List")))) |
| 65 | |
| 66 | (define (rdf-axioms-container container) |
| 67 | (list |
| 68 | (make-rdf-triple |
| 69 | container (rdf-iri "type") (rdf-iri "Property")))) |
| 70 | |
| 71 | (define (rdf-container-property? p) |
| 72 | (define rdf-container-property-base (rdf-iri "_")) |
| 73 | (and (string? p) |
| 74 | (> (string-length p) (string-length rdf-container-property-base)) |
| 75 | (equal? (substring p 0 (string-length rdf-container-property-base)) |
| 76 | rdf-container-property-base) |
| 77 | (string->number |
| 78 | (substring p (string-length rdf-container-property-base))))) |
| 79 | |
| 80 | (define (rdf-container-properties g) |
| 81 | (let loop ((answer '()) (g g)) |
| 82 | (match g |
| 83 | (() (if (null? answer) (list (rdf-iri "_1")) answer)) |
| 84 | ((($ rdf-triple subject predicate object) g ...) |
| 85 | (let* ((answer (if (and (rdf-container-property? subject) |
| 86 | (not (member subject answer))) |
| 87 | (cons subject answer) |
| 88 | answer)) |
| 89 | (answer (if (and (rdf-container-property? predicate) |
| 90 | (not (member predicate answer))) |
| 91 | (cons predicate answer) |
| 92 | answer)) |
| 93 | (answer (if (and (rdf-container-property? object) |
| 94 | (not (member object answer))) |
| 95 | (cons object answer) |
| 96 | answer))) |
| 97 | (loop answer g)))))) |
| 98 | |
| 99 | (define (augment g) |
| 100 | (let* ((g (append rdf-axioms g)) |
| 101 | (g (append |
| 102 | (append-map rdf-axioms-container (rdf-container-properties g)) |
| 103 | g))) |
| 104 | (let loop ((g g)) |
| 105 | (let ((augment-set |
| 106 | (let loop2 ((g2 g) (augment-set '())) |
| 107 | (match g2 |
| 108 | (() augment-set) |
| 109 | ((($ rdf-triple subject predicate object) g2 ...) |
| 110 | (let ((type-triple |
| 111 | (if (and (rdf-literal? object) |
| 112 | (rdf-datatype? (rdf-literal-type object))) |
| 113 | (make-rdf-triple object (rdf-iri "type") |
| 114 | (rdf-literal-type object)) |
| 115 | #f)) |
| 116 | (property-triple |
| 117 | (make-rdf-triple predicate (rdf-iri "type") |
| 118 | (rdf-iri "Property")))) |
| 119 | (loop2 |
| 120 | g2 |
| 121 | (append |
| 122 | (if (or (not type-triple) (member type-triple g) |
| 123 | (member type-triple augment-set)) |
| 124 | '() |
| 125 | (list type-triple)) |
| 126 | (if (or (member property-triple g) |
| 127 | (member type-triple augment-set)) |
| 128 | '() |
| 129 | (list property-triple)) |
| 130 | augment-set)))))))) |
| 131 | (if (null? augment-set) |
| 132 | g |
| 133 | (loop (append augment-set g))))))) |
| 134 | |
| 135 | (define (equiv? n1 n2) |
| 136 | (match (list n1 n2) |
| 137 | ((($ rdf-literal l1 ($ rdf-datatype _ _ _ _ lexical->value1 _) lang1) |
| 138 | ($ rdf-literal l2 ($ rdf-datatype _ _ _ _ lexical->value2 _) lang2)) |
| 139 | (and (equal? lang1 lang2) |
| 140 | (equal? (lexical->value1 l1)) |
| 141 | (equal? (lexical->value2 l2)))) |
| 142 | (_ (equal? n1 n2)))) |
| 143 | |
| 144 | (define (validate-mapping mapping g1 g2) |
| 145 | (match g1 |
| 146 | ('() #t) |
| 147 | ((t1 g1 ...) |
| 148 | (and (not (null? (filter |
| 149 | (lambda (t2) |
| 150 | (let ((s1 (rdf-triple-subject t1)) |
| 151 | (s2 (rdf-triple-subject t2)) |
| 152 | (p1 (rdf-triple-predicate t1)) |
| 153 | (p2 (rdf-triple-predicate t2)) |
| 154 | (o1 (rdf-triple-object t1)) |
| 155 | (o2 (rdf-triple-object t2))) |
| 156 | (and |
| 157 | (if (blank-node? s1) |
| 158 | (equiv? (assoc-ref mapping s1) s2) |
| 159 | (equiv? s1 s2)) |
| 160 | (equal? p1 p2) |
| 161 | (if (blank-node? o1) |
| 162 | (equiv? (assoc-ref mapping o1) o2) |
| 163 | (equiv? o1 o2))))) |
| 164 | g2))) |
| 165 | (validate-mapping mapping g1 g2))))) |
| 166 | |
| 167 | (define (entails? g e) |
| 168 | "Return true if g entails e" |
| 169 | (or (not (consistent-graph? g)) |
| 170 | (d:entails? (augment g) e))) |
| 171 |