How to create transitive function in LISP for R relation?

Question

To construct the transitive and reflexive closure R *. The binary relation R = {(1,1), (1,2), (2,1), (2,2), (3,1), (3,4), (4,1), (4,2), (4,4)}

Answer 1

What we can do is turn the data into some graph structure, like an adjacency hash table. Then we can traverse it and back-fill the missing transitive and reflexive relationships.

TXR Lisp program:

;; association data
(defvar rel-pairs '((1 1) (1 2) (2 1) (2 2) (3 1) (3 4) (4 1) (4 2) (4 4)))

;; turn data into hash table associating each domain value
;; with its range values.
(defvar rel [group-reduce (hash) car (op cons (cadr @2) @1) rel-pairs])

(defun ensure-trans-reflex (hash)
  ;; ensure reflexivity: if [hash key] maps to some values,
  ;; each of those values should appears as keys mapping
  ;; back to the key.
  (dohash (key values hash)
    (each ((val values))
      (pushnew key [hash val])))

  ;; ensure transivity: individually starting at each
  ;; key in the hash, we recursively traverse the graph,
  ;; and associate that key with values thus reachable.
  (dohash (key values hash hash)
    (let ((visited (hash)))
      (labels ((transitivize (key value)
                 (each ((next-val [hash value]))
                   (when (test-set [visited next-val])
                     (pushnew next-val [hash key])
                     (transitivize key next-val)))))
        (each ((val values))
          (transitivize key val))))))

(prinl rel)
(ensure-trans-reflex rel)
(prinl rel)

Output:

$ txr rel.tl 
#H(() (1 (2 1)) (2 (2 1)) (3 (4 1)) (4 (4 2 1)))
#H(() (1 (4 3 2 1)) (2 (3 4 2 1)) (3 (2 3 4 1)) (4 (3 4 2 1)))

Basically, the example data ends up associating every key with every key including itself.

Answer 2

Here is an implementation in Common Lisp which exhibits a problem with a naïve approach to this sort of question.

First of all some definitions.

• The kernel of the relation is a map with entries which look like (x . y). R(a, b) if there is an entry in the kernel like (a . b). I am not sure if 'kernel' is the correct mathematical term (I'm pretty sure it's not), but it's what I'm going to use.
• The relation R is reflexive if R(a, a) for any a which occurs either in the domain or the range of the relation.
• The transitive closure of R, R* is the relation such that R*(a, b if R(a, b) or (R(a, c) and R*(c, b)).

So I'm going to implement the kernel of the map just as a list, and I will explicitly use car, cdr, and cons to extract the parts of entries in the kernel. This is grotty old-fashioned Lisp, but in this case it's pretty much fine, since the natural objects in this part of the language (conses) map very nicely onto the objects in the problem. Note also that I have not tried to use any fancy data structures at all: everything is just walking down lists. This would make the thing slow if the kernel was very large. But it's not very large.

Here is the kernel you are given:

(defparameter *kernel*
  '((1 . 1)
    (1 . 2)
    (2 . 1)
    (2 . 2)
    (3 . 1)
    (3 . 4)
    (4 . 1)
    (4 . 2)
    (4 . 4)))

This kernel is not reflexive: (3 . 3) is missing for instance. Here is a function which, given a kernel, returns a reflexive version of it. This function has very poor complexity, but the kernel is small and the function gets called once.

(defun reflexifize-kernel (kernel)
  ;; given the kernel of a map, return a reflexive version of it
  ;; This has pretty grotty complexity but it gets called only once
  (loop for element in (loop with d/r = '()
                             for e in kernel
                             do (pushnew (car e) d/r)
                             do (pushnew (cdr e) d/r)
                             finally (return d/r))
        for ik = (cons element element)
        unless (member ik kernel :test #'equal)
        collect ik into identities
        finally (return (append kernel identities))))

And we can check this:

> (reflexifize-kernel *kernel*)
((1 . 1)
 (1 . 2)
 (2 . 1)
 (2 . 2)
 (3 . 1)
 (3 . 4)
 (4 . 1)
 (4 . 2)
 (4 . 4)
 (3 . 3))

You can see it's added the appropriate entry at the end (and it would have added more entries if it needed to).

Now I'll write a function which, given the left-hand-side of a mapping and a kernel returns two things:

• the first match for this left-hand-side in the kernel, or nil if there is none;
• the remainder of the kernel after this match, or () if there is one (note that nil and () are the same in Common Lisp, but they might not be in other Lisps).

The nice thing here is that we can just use the remainder of the kernel to look for more matches, and this function works really nicely with the implementation of the kernel above: this is a case where Lisp's data structures really work well for us.

(defun next-match (lhs kernel)
  ;; return the next match (as (lhs . rhs)) for lhs in kernel, and the
  ;; remainder of the kernel, or nil and () if there is no match
  (let ((found (member lhs kernel :key #'car)))
    (if found
        (values (first found) (rest found))
      (values nil '()))))

So, now we can write a function, Rp which is true if R(a, b) is true:

(defun Rp (lhs rhs kernel)
  ;; is R(lhs, rhs) true
  (multiple-value-bind (entry remaining-kernel) (next-match lhs kernel)
    (cond ((null entry)
           nil)
          ((eql (cdr entry) rhs)
           t)
          (t (Rp lhs rhs remaining-kernel)))))

This is called Rp because it's a predicate (ending in p in the usual Lisp convention), and it tells us if two elements satisfy R. And of course since CL is case-insensitive by default, this is the same function as rp.

And this function works fine:

 > (rp 1 1 (reflexifize-kernel *kernel*))
t

> (rp 1 3 (reflexifize-kernel *kernel*))
nil

And now we can write R*p: it's clearer, I think and certainly more efficient to write a 'unified' version of R*p which does not rely on Rp, but is very similar code with it: it's really just got a final step which searches for the transitive closure.

(defun R*p (lhs rhs kernel)
  ;; is lhs related to rhs in kernel? (See note below!)
  (multiple-value-bind (entry remaining-kernel) (next-match lhs kernel)
    (if (null entry)
        nil
      (let ((match-rhs (cdr entry)))
        (if (eql rhs match-rhs)
            t
          (or (R*p lhs rhs remaining-kernel)
              (R*p match-rhs rhs kernel)))))))

OK, so this looks obviously correct, right?

1. first we look for a match for lhs;
2. if there's a match, and its rhs is rhs then we're done;
3. if there isn't then
   1. first search for more matches in the kernel and check them
   2. if that fails look for matches for the rhs we found whose rhs is rhs.

And this is just transparently the definition of the transitive closure, right? So if we feed it a reflexive kernel (which we can create now), it will work.

Well, no, it won't work. It won't work because there are loops in the kernel you've been given. Let's say we want to call (R*p 1 3 (reflexivize-kernel *kernel*)). It's obvious from the kernel that this should be false.

But in fact the function fails to terminate. It fails to terminate because it finds there's an entry for R(1, 2) and so it starts looking for R*(2, 3): it then finds R(2, 1), starts looking for R*(1, 3) ... oops.

(Note that the implementation above does depth-first search. Breadth-first search doesn't help: it will help find a mapping when there is one but when there isn't it will just loop in the same way.)

The way to deal with this is to use what's called an occurs check: when searching we keep track of the things we have already looked at up the search tree. If we find we're looking at a lhs which we have already looked at we fail immediately, as this is a loop. Here is an implementation of a version of R*p which does that, using a local function so we don't need to provide the so-far list in the interface, whichh would be annoying.

(defun R*p (lhs rhs kernel)
  ;; is lhs related to rhs in kernel, with an occurs check.
  (labels ((R*p-loop (lhs rhs kernel so-far)
             (if (member lhs so-far)
                 ;; we've looped, give up
                 nil
               (multiple-value-bind (entry remaining-kernel)
                   (next-match lhs kernel)
                 (if (null entry)
                     nil
                   (let ((match-rhs (cdr entry)))
                     (if (eql rhs match-rhs)
                         t
                       (or (R*p-loop lhs rhs remaining-kernel so-far)
                           (R*p-loop match-rhs rhs kernel
                                          (cons lhs so-far))))))))))
    (R*p-loop lhs rhs kernel '())))

And this version works:

> (R*p 1 3 (reflexifize-kernel *kernel*))
nil

> (R*p 1 1 (reflexifize-kernel *kernel*))
t

> (R*p 1 2 (reflexifize-kernel *kernel*))
t

> (R*p 2 1 (reflexifize-kernel *kernel*))
t

> (R*p 2 3 (reflexifize-kernel *kernel*))
nil