;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library is distributed in the hope that it will be useful,

;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(define-module (rdf rdf)

  #:use-module (srfi srfi-1)

  #:use-module (srfi srfi-9)

  #:use-module (sxml simple)

  #:use-module (ice-9 match)

  #:export (rdf-datatype

            make-rdf-datatype

            rdf-datatype?

            rdf-datatype-iris

            rdf-datatype-description

            rdf-datatype-lexical?

            rdf-datatype-value?

            rdf-datatype-lexical->value

            rdf-datatype-value->lexical

            rdf:langString

            rdf:XMLLiteral

            rdf-vocabulary

            make-rdf-vocabulary

            rdf-vocabulary?

            rdf-vocabulary-datatypes

            rdf-vocabulary-order

            rdf-vocabulary-compatible?

            rdf-dataset

            make-rdf-dataset

            rdf-dataset?

            rdf-dataset-default-graph

            rdf-dataset-named-graphs

            rdf-triple

            make-rdf-triple

            rdf-triple?

            rdf-triple-subject

            rdf-triple-predicate

            rdf-triple-object

            rdf-literal

            make-rdf-literal

            rdf-literal?

            rdf-literal-lexical-form

            rdf-literal-type

            rdf-literal-langtag

            blank-node?

            rdf-graph?

            merge-graphs

            rdf-isomorphic?

            rdf-dataset-isomorphic?

            recognize))

;; From the specification:

;;   Datatypes are used with RDF literals to represent values such as strings,

;;   numbers and dates.  A datatype consists of a lexical space, a value space

;;   and a lexical-to-value mapping, and is denoted by one or more IRIs.

;;

;;   The lexical space of a datatype is a set of Unicode [UNICODE] strings.

;;

;;   The lexical-to-value mapping of a datatype is a set of pairs whose first

;;   element belongs to the lexical space, and the second element belongs to the

;;   value space of the datatype.  Each member of the lexical space is paired

;;   with exactly one value, and is a lexical representation of that value.  The

;;   mapping can be seen as a function from the lexical space to the value space.

;;

;; In addition to the specification, we introduce value->lexical, a canonical

;; function to map values to the lexical space.  An important property is that

;;   for any val, (value? val) implies:

;;           (equal? (lexical->value (value->lexical val)) val)

;;

;; We also introduce a list of IRIs that denote this type, as more than one

;; IRI can denote a type.  This is set to a list of IRIs, but may be changed

;; to a function to denote a set in the future.

;;

;; We also introduce a description, a text that helps humans understand the

;; purpose of the datatype.

(define-record-type rdf-datatype

  (make-rdf-datatype iris description lexical? value? lexical->value value->lexical)

  rdf-datatype?

  (iris           rdf-datatype-iris)

  (description    rdf-datatype-description)

  (lexical?       rdf-datatype-lexical?)

  (value?         rdf-datatype-value?)

  (lexical->value rdf-datatype-lexical->value)

  (value->lexical rdf-datatype-value->lexical))

(define rdf:langString

  (make-rdf-datatype

    '("http://www.w3.org/1999/02/22-rdf-syntax-ns#langString")

    "A literal is a language-tagged string if the third element is present.

Lexical representations of language tags MAY be converted to lower case.  The

value space of language tags is always in lower case."

    string?

    string?

    string-downcase

    identity))

(define rdf:XMLLiteral

  (make-rdf-datatype

    '("http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral")

    "RDF provides for XML content as a possible literal value.  Such content

is indicated in an RDF graph using a literal whose datatype is set to

rdf:XMLLiteral.  This datatype is defined as non-normative because it depends

on [DOM4], a specification that has not yet reached W3C Recommendation status."

    (lambda (l)

      (false-if-exception (xml->sxml l)))

    (lambda (v)

      (false-if-exception (sxml->xml v)))

    xml->sxml

    sxml->xml))

;; In addition to the specification, we define a vocabulary, which will be

;; passed to entailments that need one.

;;

;; datatypes: a list of <rdf-datatype> records.

;; order: a procedure that takes two arguments and returns whether the value

;;        space of the firts is included in the value space of the second

;; compatible?: a procedure that takes two arguments and returns whether the

;;              intersection of their value space is not empty

(define-record-type rdf-vocabulary

  (make-rdf-vocabulary datatypes order compatible?)

  rdf-vocabulary?

  (datatypes   rdf-vocabulary-datatypes)

  (order       rdf-vocabulary-order)

  (compatible? rdf-vocabulary-compatible?))

;; From the specification:

;;   An RDF dataset is a collection of RDF graphs, and comprises:

;;

;;   * Exactly one default graph, being an RDF graph.  The default graph does

;;     not have a name and MAY be empty.

;;   * Zero or more named graphs.  Each named graph is a pair consisting of an

;;     IRI or a blank node (the graph name), and an RDF graph.  Graph names are

;;     unique within an RDF dataset.

;;

;; We represent named graphs with a association list whose keys are IRIs or

;; blank nodes, and values are RDF graphs.

(define-record-type rdf-dataset

  (make-rdf-dataset default-graph named-graphs)

  rdf-dataset?

  (default-graph rdf-dataset-default-graph)

  (named-graphs  rdf-dataset-named-graphs))

;; From the specification:

;;   An RDF triple consists of three components:

;;

;;   * the subject, which is an IRI or a blank node

;;   * the predicate, which is an IRI

;;   * the object, which is an IRI, a literal or a blank node

(define-record-type rdf-triple

  (make-rdf-triple subject predicate object)

  rdf-triple?

  (subject   rdf-triple-subject)

  (predicate rdf-triple-predicate)

  (object    rdf-triple-object))

;; From the specification:

;;   A literal in an RDF graph consists of two or three elements:

;;

;;   * a lexical form, being a Unicode [UNICODE] string, which SHOULD be in

;;     Normal Form C [NFC],

;;   * a datatype IRI, being an IRI identifying a datatype that determines how

;;     the lexical form maps to a literal value, and

;;   * if and only if the datatype IRI is `http://www.w3.org/1999/02/22-rdf-syntax-ns#langString`,

;;     a non-empty language tag as defined by [BCP47].  The language tag MUST

;;     be well-formed according to section 2.2.9 of [BCP47].

(define-record-type rdf-literal

  (make-rdf-literal lexical-form type langtag)

  rdf-literal?

  (lexical-form rdf-literal-lexical-form)

  (type         rdf-literal-type)

  (langtag      rdf-literal-langtag))

;; From the specification:

;;   Blank nodes are disjoint from IRIs and literals.  Otherwise, the set of

;;   possible blank nodes is arbitrary.  RDF makes no reference to any internal

;;   structure of blank nodes.

;;

;; Here, we will use integers as blank nodes

(define blank-node? integer?)

;; From the specification:

;;   An RDF graph is a set of RDF triples.

;;

;; We represent a graph as a list of RDF triples

(define (rdf-graph? graph)

  (and (list? graph) (null? (filter (lambda (t) (not (rdf-triple? t))) graph))))

;; The following is for a merging procedure, where we rename blank nodes to ensure

;; we are not merging blank nodes that have the same name

(define (last-blank g)

  "Retun the biggest blank node identifier in g"

  (let loop ((g g) (m 0))

    (match g

      ('() m)

      ((triple g ...)

       (loop g (max m

                   (if (blank-node? (rdf-triple-subject triple))

                       (rdf-triple-subject triple)

                       0)

                   (if (blank-node? (rdf-triple-object triple))

                       (rdf-triple-object triple)

                       0)))))))

(define (rename-blanks g num)

  "Return the same graph, but blank nodes are renamed from num"

  (let loop ((g g) (renamings '()) (num num) (result '()))

    (match g

      ('() result)

      ((triple g ...)

       (let* ((subject (rdf-triple-subject triple))

              (num (if (and (blank-node? subject)

                            (assoc-ref renamings subject))

                       num

                       (+ num 1)))

              (renamings

                (if (and (blank-node? subject)

                         (assoc-ref renamings subject))

                    renamings

                    (cons (cons subject num) renamings)))

              (subject

                (if (blank-node? subject)

                    (assoc-ref renamings subject)

                    subject))

              (predicate (rdf-triple-predicate triple))

              (object (rdf-triple-object triple))

              (num (if (and (blank-node? object)

                            (assoc-ref renamings object))

                       num

                       (+ num 1)))

              (renamings

                (if (and (blank-node? object)

                         (assoc-ref renamings object))

                    renamings

                    (cons (cons object num) renamings)))

              (object

                (if (blank-node? object)

                    (assoc-ref renamings object)

                    object)))

           (loop g renamings num (cons (make-rdf-triple subject predicate object)

                                       result)))))))

(define (merge-graphs g1 g2)

  "Merge two graphs g1 and g2.  This is the same as append, but we need to make

sure we rename blank nodes, or some nodes will be merged when they shouldn't."

  (append g1 (rename-blanks g2 (last-blank g1))))

;; Next, a predicate on isomorphisms between two graphs.  Two graphs are isomorphic

;; when each triple has a corresponding triple in the other graph.

;;

;; To take blank nodes into account, there needs to be a mapping from blank nodes

;; of the first graph to blank nodes of the other graph in order to prove

;; isomorphism.

;;

;; First, we compare the two graphs and find possible constraints on that mapping.

;; for instance, if one graph has (_:1, p, o) and the other (_:2, p, o), then

;; a possible constraint is that _:1 maps to _:2. If the other graph also has

;; (_:3, p, o) then maybe _:1 actually maps to _:3.

;;

;; Constraints are either "none" (no constraint), "equiv" (a mapping between two

;; blank node identifiers), "or" (a disjunction) or "and" (a conjunction).

;; By comparing the triples of the first graph, we create an conjunction between

;; the constraints collected from each triple. The constraints of a triple is

;; a disjunction between every case where it matches a triple from the other graph.

;; That creates zero, one or two constraints (depending on the number of blank

;; nodes).

;;

;; These constraints are transformed in a normal form, as a list of lists of

;; conjunctions. Each list is a candidate mapping. sat? is used to evaluate the

;; candidate mapping and ensure it is an isomorphism between the two sets of

;; blank nodes. For every sat? equivalences, we check that the mapping actually

;; maps triples of g1 to triples of g2, and its reverse mapping maps triples of

;; g2 to triples of g1. Whenever one mapping works, the two graphs are equivalent.

;; If no mapping works, the two graphs are not equivalent.

(define (sat? equivalences)

  "Return whether the set of equivalences satisfies the condition that it represents

an isomorphism between two blank node sets: for every equality, check that the

first component is always associated to the same second component, and that the

second component is always associated with the first."

  (match equivalences

    ('() #t)

    (((first . second) equivalences ...)

     (if (and (null? (filter

                       (lambda (eq)

                         (and (equal? (car eq) first)

                              (not (equal? (cdr eq) second))))

                       equivalences))

              (null? (filter

                       (lambda (eq)

                         (and (not (equal? (car eq) first))

                              (equal? (cdr eq) second)))

                       equivalences)))

         (sat? equivalences)

         #f))))

(define (filter-sat equivalences)

  (if (list? equivalences)

      (filter

        (lambda (eq)

          (if (member eq '(bot none))

              eq

              (if (sat? eq)

                  eq

                  'bot)))

        equivalences)

      equivalences))

(define (merge-joins l1 l2)

  (cond

    ((null? l1) l2)

    ((null? l2) l1)

    (else

      (fold

        (lambda (e1 res)

          (append

            (map (lambda (e2)

                   (append e1 e2))

                 l2)

            res))

        '()

        l1))))

(define (to-disjunctions constraints)

  (match constraints

    (('equiv b1 b2) (list (list (cons b1 b2))))

    ('none (list (list)))

    ('bot 'bot)

    (('or e1 e2)

     (let ((e1 (filter-sat (to-disjunctions e1)))

           (e2 (filter-sat (to-disjunctions e2))))

       (cond

         ((equal? e2 'bot)

          e1)

         ((equal? e1 'bot)

          e2)

         ((equal? e2 'none)

          'none)

         ((equal? e1 'none)

          'none)

         ((equal? e1 e2)

          e1)

         (else

           (append e1 e2)))))

    (('and e1 e2)

     (let ((e1 (filter-sat (to-disjunctions e1)))

           (e2 (filter-sat (to-disjunctions e2))))

       (cond

         ((equal? e1 'bot)

          'bot)

         ((equal? e2 'bot)

          'bot)

         ((equal? e2 'none)

          e1)

         ((equal? e1 'none)

          e2)

         ((equal? e1 e2)

          e1)

         (else

           (merge-joins e1 e2)))))))

(define (generate-triple-constraints t1 t2)

  (match t1

    (($ rdf-triple s1 p1 o1)

     (match t2

       (($ rdf-triple s2 p2 o2)

        (if (and (or (equal? s1 s2) (and (blank-node? s1) (blank-node? s2)))

                 (equal? p1 p2)

                 (or (equal? o1 o2) (and (blank-node? o1) (blank-node? o2))))

            (list 'and

                  (if (blank-node? s1)

                      (list 'equiv s1 s2)

                      'none)

                  (if (blank-node? o1)

                      (list 'equiv o1 o2)

                      'none))

            #f))))))

(define (generate-constraints t1 g2)

  (match g2

    ('() 'bot)

    ((t2 g2 ...)

     (let ((c (generate-triple-constraints t1 t2)))

       (if c

         (list 'or c (generate-constraints t1 g2))

         (generate-constraints t1 g2))))))

(define (generate-graph-constraints g1 g2)

  (fold (lambda (t constraints)

          (list 'and (generate-constraints t g2) constraints))

        'none g1))

(define (reverse-mapping mapping)

  (let loop ((mapping mapping) (result '()))

  (match mapping

    ('() result)

    (((first . second) mapping ...)

     (loop mapping (cons (cons second first) result))))))

(define (validate-mapping mapping g1 g2)

  (match g1

    ('() #t)

    ((t1 g1 ...)

     (and (not (null? (filter

                        (lambda (t2)

                          (let ((s1 (rdf-triple-subject t1))

                                (s2 (rdf-triple-subject t2))

                                (p1 (rdf-triple-predicate t1))

                                (p2 (rdf-triple-predicate t2))

                                (o1 (rdf-triple-object t1))

                                (o2 (rdf-triple-object t2)))

                            (and

                              (if (blank-node? s1)

                                  (equal? (assoc-ref mapping s1) s2)

                                  (equal? s1 s2))

                              (equal? p1 p2)

                              (if (blank-node? o1)

                                  (equal? (assoc-ref mapping o1) o2)

                                  (equal? o1 o2)))))

                        g2)))

          (validate-mapping mapping g1 g2)))))

(define (rdf-isomorphic? g1 g2)

  "Compare two graphs and return whether they are isomorph."

  (let* ((constraints (generate-graph-constraints g1 g2))

         (disjunctions (to-disjunctions (simplify-constraints constraints))))

    (if (list? disjunctions)

        (let loop ((disjunctions (filter sat? disjunctions)))

          (match disjunctions

            ('() (and (null? g1) (null? g2)))

            ((mapping disjunctions ...)

             (if (and (validate-mapping mapping g1 g2)

                      (validate-mapping (reverse-mapping mapping) g2 g1))

               #t

               (loop disjunctions)))))

        #f)))

(define* (simplify-constraints c #:optional (equivalences '()))

  (match c

    ('bot 'bot)

    ('none 'none)

    (('equiv a b)

     (if (assoc-ref equivalences a)

         (if (equal? (assoc-ref equivalences a) b)

             'none

             'bot)

         c))

    (('and e1 e2)

     (match (simplify-constraints e1 equivalences)

       ('bot 'bot)

       ('none (simplify-constraints e2 equivalences))

       (('equiv a b)

        (let ((e2 (simplify-constraints e2 (cons (cons a b) equivalences))))

          (match e2

            ('bot 'bot)

            ('none (list 'equiv a b))

            (e2 (list 'and (list 'equiv a b) (simplify-constraints e2 (cons (cons a b) equivalences)))))))

       (e1

         (match (simplify-constraints e2 equivalences)

           ('bot 'bot)

           ('none e1)

           (('equiv a b)

            (list 'and (list 'equiv a b) (simplify-constraints e1 (cons (cons a b) equivalences))))

           (e2

             (list 'and e1 e2))))))

    (('or e1 e2)

     (let ((e1 (simplify-constraints e1 equivalences))

           (e2 (simplify-constraints e2 equivalences)))

       (cond

         ((equal? e1 'bot)

          e2)

         ((equal? e2 'bot)

          e1)

         ((equal? e1 'none)

          'none)

         ((equal? e2 'none)

          'none)

         ((equal? e1 e2)

          e1)

         (else

           (list 'or e1 e2)))))))

(define (generate-dataset-constraints d1 d2)

  (let ((g1 (rdf-dataset-default-graph d1))

        (g2 (rdf-dataset-default-graph d2))

        (ng1 (rdf-dataset-named-graphs d1))

        (ng2 (rdf-dataset-named-graphs d2)))

    (list 'and (simplify-constraints (generate-graph-constraints g1 g2))

          (if (null? ng1)

              'none

              (fold (lambda (ng1 constraints)

                      (match ng1

                        ((n1 . g1)

                         (list

                           'and

                           (if (blank-node? n1)

                             (fold (lambda (ng2 constraints)

                                     (list 'or (list 'and (list 'equiv n1 (car ng2))

                                                     (simplify-constraints

                                                       (generate-graph-constraints

                                                         g1 (cdr ng2))))

                                           constraints))

                                   'bot

                                   (filter (lambda (g2) (blank-node? (car g2))) ng2))

                             (let ((g2 (assoc-ref ng2 n1)))

                               (if g2

                                   (list 'and (simplify-constraints

                                                (generate-graph-constraints g1 g2))

                                         constraints)

                                   'bot)))

                           constraints))))

                    'none ng1)))))

(define (validate-dataset-mapping mapping d1 d2)

  (define (validate-named-graph name graph)

    (let ((graph2 (if (blank-node? name)

                      (assoc-ref (rdf-dataset-named-graphs d2)

                                 (assoc-ref mapping name))

                      (assoc-ref (rdf-dataset-named-graphs d2) name))))

      (and graph2 (validate-mapping mapping graph graph2))))

  (and (validate-mapping mapping (rdf-dataset-default-graph d1)

                         (rdf-dataset-default-graph d2))

       (null? (filter

                (lambda (ng1)

                  (match ng1

                    ((name . graph)

                     (not (validate-named-graph name graph)))))

                (rdf-dataset-named-graphs d1)))))

(define (rdf-dataset-isomorphic? d1 d2)

  "Compare two datasets and return whether they are isomorphic."

  (let* ((constraints (generate-dataset-constraints d1 d2))

         (disjunctions (to-disjunctions constraints)))

    (if (list? disjunctions)

        (let loop ((disjunctions (filter sat? disjunctions)))

          (match disjunctions

            ('() (and (null? (rdf-dataset-default-graph d1))

                      (null? (rdf-dataset-default-graph d2))

                      (null? (rdf-dataset-named-graphs d1))

                      (null? (rdf-dataset-named-graphs d2))))

            ((mapping disjunctions ...)

             (or (and (validate-dataset-mapping mapping d1 d2)

                      (validate-dataset-mapping (reverse-mapping mapping) d2 d1))

                 (loop disjunctions)))))

        #f)))

;; Recognizing datatypes is a transformation on the graph to add the proper

;; datatype to literals, and replace IRIs that represent a datatype with the

;; datatype it represents.  This is useful for some entailment regimes, such

;; as the RDF or RDFS entailment regimes.

(define (recognize-data d datatypes)

  (match d

    ((? string? iri) 

     (let loop ((datatypes datatypes))

       (if (null? datatypes)

           iri

           (if (member iri (rdf-datatype-iris (car datatypes)))

               (car datatypes)

               (loop (cdr datatypes))))))

    (($ rdf-literal literal-form type langtag)

     (let loop ((datatypes datatypes))

       (if (null? datatypes)

           (make-rdf-literal literal-form type langtag)

           (if (member type (rdf-datatype-iris (car datatypes)))

               (make-rdf-literal literal-form (car datatypes) langtag)

               (loop (cdr datatypes))))))

    (_ d)))

(define (recognize-triple t datatypes)

  (match t

    (($ rdf-triple subject predicate object)

     (make-rdf-triple

       (recognize-data subject datatypes)

       predicate

       (recognize-data object datatypes)))))

(define (recognize graph vocabulary)

  (match graph

    (() '())

    ((t graph ...)

     (cons

       (recognize-triple t (rdf-vocabulary-datatypes vocabulary))

       (recognize graph vocabulary)))))