Add RDF entailment regime

Julien LepillerSat Apr 04 00:47:35+0200 2020

63e0714

Add RDF entailment regime

Makefile.am

11 
include guile.am
22 
33 
SOURCES= \
4+
		 rdf/entailment/d.scm \
5+
  rdf/entailment/rdf.scm \
46 
  rdf/entailment/simple.scm \
57 
  rdf/rdf.scm \
68 
  rdf/xsd.scm \
rdf/entailment/d.scm unknown status 1
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 d)
19+
  #:use-module (ice-9 match)
20+
  #:use-module (rdf rdf)
21+
  #:use-module ((rdf entailment simple) #:prefix simple:)
22+
  #:use-module (srfi srfi-1)
23+
  #:export (consistent-graph?
24+
            entails?))
25+
26+
(define (consistent-graph? graph)
27+
  (define consistent-data?
28+
    (match-lambda
29+
      (($ rdf-literal form ($ rdf-datatype _ _ lexical? _ _ _) _)
30+
       (lexical? form))
31+
      (_ #t)))
32+
33+
  (match graph
34+
    ('() #t)
35+
    ((($ rdf-triple subject predicate object) graph ...)
36+
     (and (consistent-data? subject) (consistent-data? object)
37+
          (consistent-graph? graph)))))
38+
39+
;; G entails E if E has an instance (where blank nodes are replaced by literals
40+
;; or IRIs) that is a subgraph of G.
41+
;;
42+
;; We re-use similar procedures to verifying isomorphism of graphs, but this time
43+
;; blank nodes can also map to literals and IRIs.
44+
45+
(define (sat? equivalences)
46+
  "Return whether the set of equivalences satisfies the condition that it represents
47+
an isomorphism between two blank node sets: for every equality, check that the
48+
first component is always associated to the same second component, and that the
49+
second component is always associated with the first."
50+
  (match equivalences
51+
    ('() #t)
52+
    (((first . second) equivalences ...)
53+
     (if (and (null? (filter
54+
                       (lambda (eq)
55+
                         (and (equal? (car eq) first)
56+
                              (not (equal? (cdr eq) second))))
57+
                       equivalences))
58+
              (null? (filter
59+
                       (lambda (eq)
60+
                         (and (not (equal? (car eq) first))
61+
                              (equal? (cdr eq) second)))
62+
                       equivalences)))
63+
         (sat? equivalences)
64+
         #f))))
65+
66+
(define (merge-joins l1 l2)
67+
  (cond
68+
    ((null? l1) l2)
69+
    ((null? l2) l1)
70+
    (else
71+
      (fold
72+
        (lambda (e1 res)
73+
          (append
74+
            (map (lambda (e2)
75+
                   (append e1 e2))
76+
                 l2)
77+
            res))
78+
        '()
79+
        l1))))
80+
81+
(define (to-disjunctions constraints)
82+
  (match constraints
83+
    (('equiv b1 b2) (list (list (cons b1 b2))))
84+
    ('none (list (list)))
85+
    ('bot 'bot)
86+
    (('or e1 e2)
87+
     (let ((e1 (to-disjunctions e1))
88+
           (e2 (to-disjunctions e2)))
89+
       (cond
90+
         ((equal? e2 'bot)
91+
          e1)
92+
         ((equal? e1 'bot)
93+
          e2)
94+
         (else
95+
           (append e1 e2)))))
96+
    (('and e1 e2)
97+
     (let ((e1 (to-disjunctions e1))
98+
           (e2 (to-disjunctions e2)))
99+
       (cond
100+
         ((equal? e1 'bot)
101+
          'bot)
102+
         ((equal? e2 'bot)
103+
          'bot)
104+
         (else
105+
           (merge-joins e1 e2)))))))
106+
107+
(define (generate-triple-constraints t1 t2)
108+
  (match t1
109+
    (($ rdf-triple s1 p1 o1)
110+
     (match t2
111+
       (($ rdf-triple s2 p2 o2)
112+
        (if (and (or (equiv? s1 s2) (blank-node? s1))
113+
                 (equal? p1 p2)
114+
                 (or (equiv? o1 o2) (blank-node? o1)))
115+
            (list 'and
116+
                  (if (blank-node? s1)
117+
                      (list 'equiv s1 s2)
118+
                      'none)
119+
                  (if (blank-node? o1)
120+
                      (list 'equiv o1 o2)
121+
                      'none))
122+
            #f))))))
123+
124+
(define (generate-constraints t1 g2)
125+
  (match g2
126+
    ('() 'bot)
127+
    ((t2 g2 ...)
128+
     (let ((c (generate-triple-constraints t1 t2)))
129+
       (if c
130+
         (list 'or c (generate-constraints t1 g2))
131+
         (generate-constraints t1 g2))))))
132+
133+
(define (equiv? n1 n2)
134+
  (match (list n1 n2)
135+
    ((($ rdf-literal l1 ($ rdf-datatype _ _ _ _ lexical->value1 _) lang1)
136+
      ($ rdf-literal l2 ($ rdf-datatype _ _ _ _ lexical->value2 _) lang2))
137+
     (and (equal? (and lang1 (string-downcase lang1))
138+
                  (and lang2 (string-downcase lang2)))
139+
          (equal? (lexical->value1 l1))
140+
          (equal? (lexical->value2 l2))))
141+
    (_ (equal? n1 n2))))
142+
143+
(define (validate-mapping mapping g1 g2)
144+
  (match g1
145+
    ('() #t)
146+
    ((t1 g1 ...)
147+
     (and (not (null? (filter
148+
                        (lambda (t2)
149+
                          (let ((s1 (rdf-triple-subject t1))
150+
                                (s2 (rdf-triple-subject t2))
151+
                                (p1 (rdf-triple-predicate t1))
152+
                                (p2 (rdf-triple-predicate t2))
153+
                                (o1 (rdf-triple-object t1))
154+
                                (o2 (rdf-triple-object t2)))
155+
                            (and
156+
                              (if (blank-node? s1)
157+
                                  (equiv? (assoc-ref mapping s1) s2)
158+
                                  (equiv? s1 s2))
159+
                              (equal? p1 p2)
160+
                              (if (blank-node? o1)
161+
                                  (equiv? (assoc-ref mapping o1) o2)
162+
                                  (equiv? o1 o2)))))
163+
                        g2)))
164+
          (validate-mapping mapping g1 g2)))))
165+
166+
(define (entails? g e)
167+
  "Return true if g entails e"
168+
  (or (not (consistent-graph? g))
169+
      (let* ((constraints (fold (lambda (t constraints)
170+
                                  (list 'and (generate-constraints t g) constraints))
171+
                                'none e))
172+
             (disjunctions (to-disjunctions constraints)))
173+
        (if (equal? disjunctions 'bot)
174+
            #f
175+
            (let loop ((disjunctions (filter sat? disjunctions)))
176+
              (match disjunctions
177+
                ('() #f)
178+
                ((mapping disjunctions ...)
179+
                 (if (validate-mapping mapping e g)
180+
                   #t
181+
                   (loop disjunctions)))))))))
rdf/entailment/rdf.scm unknown status 1
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+
      (() 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)))
rdf/entailment/simple.scm
9494 
           (merge-joins e1 e2)))))))
9595 
9696 
(define (generate-triple-constraints t1 t2)
97-
  (pk 'generate t1 t2)
9897 
  (match t1
9998 
    (($ rdf-triple s1 p1 o1)
10099 
     (match t2
test-modules/online.scm
2020 
  #:use-module (rnrs bytevectors)
2121 
  #:use-module (srfi srfi-1)
2222 
  #:use-module (test-modules result)
23+
  #:use-module ((rdf entailment rdf) #:prefix rdf:)
2324 
  #:use-module ((rdf entailment simple) #:prefix simple:)
2425 
  #:use-module (rdf rdf)
26+
  #:use-module ((rdf xsd) #:prefix xsd:)
2527 
  #:use-module (srfi srfi-1)
2628 
  #:use-module (turtle tordf)
2729 
  #:use-module (web client)
…
2931 
  #:export (run-test-suite
3032 
            run-test-suites))
3133 
34+
(define (find-rest node graph)
35+
  (rdf-triple-object
36+
    (car
37+
      (filter
38+
        (lambda (triple)
39+
          (and (equal? (rdf-triple-subject triple) node)
40+
               (equal? (rdf-triple-predicate triple)
41+
                       (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
42+
                                      "#rest"))))
43+
        graph))))
44+
45+
(define (find-first node graph)
46+
  (rdf-triple-object
47+
    (car
48+
      (filter
49+
        (lambda (triple)
50+
          (and (equal? (rdf-triple-subject triple) node)
51+
               (equal? (rdf-triple-predicate triple)
52+
                       (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
53+
                                      "#first"))))
54+
        graph))))
55+
56+
(define (find-list node graph)
57+
  (if (blank-node? node)
58+
      (let loop ((node node) (result '()))
59+
        (let ((first (find-first node graph))
60+
              (node (find-rest node graph)))
61+
          (if (blank-node? node)
62+
              (loop node (cons first result))
63+
              (cons first result))))
64+
      '()))
65+
3266 
(define (get-objects triples predicate)
3367 
  (map
3468 
    rdf-triple-object
…
102136 
                   #:reason (format #f "expected ~a but got ~a"
103137 
                                    expected result)))))))
104138 
      ((member type '("PositiveEntailmentTest" "NegativeEntailmentTest"))
139+
       (pk 'predicates predicates)
105140 
       (let* ((regime (rdf-literal-lexical-form
106141 
                        (car
107142 
                          (get-objects
…
109144 
                            (string-append
110145 
                              "http://www.w3.org/2001/sw/DataAccess/tests/"
111146 
                              "test-manifest#entailmentRegime")))))
147+
              (recognized
148+
                (car
149+
                  (pk 'recognized-nodes
150+
                  (get-objects
151+
                    predicates
152+
                    (string-append "http://www.w3.org/2001/sw/DataAccess/tests/"
153+
                                   "test-manifest#recognizedDatatypes"))))
154+
                )
155+
              (recognized (pk 'lst-reco (find-list recognized predicates)))
156+
              (recognized
157+
                (map
158+
                  (lambda (iri)
159+
                    (let loop ((types xsd:datatypes))
160+
                      (match types
161+
                        (() #f)
162+
                        ((type types ...)
163+
                         (if (member iri (rdf-datatype-iris type))
164+
                             (pk 'recognized-type type)
165+
                             (loop types))))))
166+
                  recognized))
167+
              (recognized (pk 'reco (append (list xsd:string rdf:langString) recognized)))
112168 
              (expected
113169 
                (car
114170 
                  (get-objects
…
138194 
                      #:result 'fail
139195 
                      #:reason (format #f "Expected positive result, got negative"))
140196 
                    (update-test-case test #:result 'pass))))
197+
           ("RDF"
198+
            (if (if (equal? expected #f)
199+
                    (rdf:consistent-graph? result)
200+
                    (rdf:entails? (recognize result recognized)
201+
                                  (recognize expected recognized)))
202+
                (if (equal? type "PositiveEntailmentTest")
203+
                    (update-test-case test #:result 'pass)
204+
                    (update-test-case test
205+
                      #:result 'fail
206+
                      #:reason "Expected negative result, got positive"))
207+
                (if (equal? type "PositiveEntailmentTest")
208+
                    (update-test-case test
209+
                      #:result 'fail
210+
                      #:reason (format #f "Expected positive result, got negative"))
211+
                    (update-test-case test #:result 'pass))))
141212 
           (_ (update-test-case test
142213 
                #:result 'skip
143214 
                #:reason (format #f "Unrecognized entailment regime: ~a"
…
198269 
                                        "tests/test-manifest#entries"))))
199270 
          manifest))))
200271 
201-
  (define (find-rest node)
202-
    (rdf-triple-object
203-
      (car
204-
        (filter
205-
          (lambda (triple)
206-
            (and (equal? (rdf-triple-subject triple) node)
207-
                 (equal? (rdf-triple-predicate triple)
208-
                         (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
209-
                                        "#rest"))))
210-
          manifest))))
211-
212-
  (define (find-first node)
213-
    (rdf-triple-object
214-
      (car
215-
        (filter
216-
          (lambda (triple)
217-
            (and (equal? (rdf-triple-subject triple) node)
218-
                 (equal? (rdf-triple-predicate triple)
219-
                         (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
220-
                                        "#first"))))
221-
          manifest))))
272+
  (define tests (find-list tests-node manifest))
222273 
223-
  (define tests
224-
    (let loop ((tests-node tests-node) (tests '()))
225-
      (let ((first (find-first tests-node))
226-
            (tests-node (find-rest tests-node)))
227-
        (if (blank-node? tests-node)
228-
            (loop tests-node (cons first tests))
229-
            tests))))
274+
  (define (subgraph-at graph node)
275+
    (let ((nodes (filter
276+
                   (lambda (t)
277+
                     (equal? (rdf-triple-subject t) node))
278+
                   graph)))
279+
      (if (null? nodes)
280+
          '()
281+
          (apply append nodes
282+
                 (map
283+
                   (lambda (n)
284+
                     (subgraph-at graph (rdf-triple-object n)))
285+
                   nodes)))))
230286 
231287 
  (cdr
232288 
    (fold
233289 
      (lambda (test result)
234290 
        (let* ((num (car result))
235291 
               (result (cdr result))
236-
               (test-predicates (filter
237-
                                  (lambda (t)
238-
                                    (equal? (rdf-triple-subject t) test))
239-
                                  manifest))
292+
               (test-predicates (subgraph-at manifest test))
240293 
               (name (lexical->value (car (get-objects test-predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#name"))))
241294 
               (description (lexical->value (car (get-objects test-predicates "http://www.w3.org/2000/01/rdf-schema#comment")))))
242295 
          (cons (+ 1 num)
243-
                (cons (make-test-case test num name description
244-
                                      (filter
245-
                                        (lambda (t)
246-
                                          (equal? (rdf-triple-subject t) test))
247-
                                        manifest)
296+
                (cons (make-test-case test num name description test-predicates
248297 
                                      #f #f)
249298 
                      result))))
250299 
      `(,num . ())