#:use-module (srfi srfi-1)

            rdf-isomorphic?))

;; 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 (merge-joins l1 l2)

  (match l1

    ('() l2)

    ((e1 l1 ...)

     (merge-joins l1 (map (lambda (e2) (append e1 e2)) l2)))))

(define (to-disjunctions constraints)

  (match constraints

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

    ('none (list (list)))

    (('or e1 e2) (append (to-disjunctions e1) (to-disjunctions e2)))

    (('and e1 e2)

     (merge-joins (to-disjunctions e1) (to-disjunctions 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

    ('() 'none)

    ((t2 g2 ...)

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

       (if c

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

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

(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 isomorphic."

  (let* ((constraints (fold (lambda (t constraints)

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

                            'none g1))

         (disjunctions (to-disjunctions constraints)))

    (pk 'dis disjunctions)

    (let loop ((disjunctions 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)))))))