Strictly Increasing Labels of Directed Graphs

In a previous post I described how one can relabel a cycle-free directed graph so that labels are stricly increasing on all paths. I did not get into this, but this simple fact allows one to re-write the incidence matrix of the directed graph as an upper triangular (or lower triangular depending on how you read the indices) matrix.

Today, I will post a lisp implementation of the algorithm. So, let me start by defining the data structure: a graph is a list of ordered pairs of integers. These integers are the original labelling of the graph. For instance,

(defparameter G '((4 2) (2 3) (1 3) (3 0)))
G

is a graph on 5 vertices. Next, I need a function which extracts the set of vertices from the set of edges.

(defun vertices (G)
   (let (res)
      (dolist (x G) 
         (dolist (u x) (if (not (member u res)) (push u res))))
      (sort res '<)))
VERTICES

Let us test it on our graph G:

(vertices G)
(0 1 2 3 4)

The functions below test whether a given vertex is respectively a source or a sink.

(defun sourcep (x G)
   (let ((H (remove-if (lambda (x) (equal (car x) (cadr x))) G)))
       (if (member x (mapcar 'cadr H))
           nil
          't)))

(defun sinkp (x G)
   (let ((H (remove-if (lambda (x) (equal (car x) (cadr x))) G)))
       (if (member x (mapcar 'car H))
           nil
           't)))
SINKP

I need to remove the trivial edges before I check if a given vertex is a source or a sink. This is reflected in the copy H of the graph G passed to the function. Again, let us test this on the vertices of G:

(mapcar (lambda (x) (list x (sourcep x G))) (vertices G))
((0 NIL) (1 T) (2 NIL) (3 NIL) (4 T))

and

(mapcar (lambda (x) (list x (sinkp x G))) (vertices G))
((0 T) (1 NIL) (2 NIL) (3 NIL) (4 NIL))

In the main part of the implementation, I will need a function which returns a source (any source) from a given graph, and a function which removes a vertex x together with all edges x is incident:

(defun get-a-source (G)
   (loop for vertex in (vertices G) 
         while (not (sourcep vertex G)) 
         finally (return vertex)))

(defun remove-vertex (x G)
   (remove-if (lambda (edge) (member x edge)) G))
REMOVE-VERTEX

Now, we are ready to implement the heart of the algorithm. The following function translate returns a list of CONS pairs in which the CAR is the old label and the CDR is the new label.

(defun translate (G &optional (m 0))
   (if (not (null G))
      (let ((x (get-a-source G)))
          (append (list (cons x m)) (translate (remove-vertex x G) (1+ m))))))
TRANSLATE

If we test translate on our graph G we get:

(translate G)
((1 . 0) (4 . 1) (2 . 2) (3 . 3))

Finally, we came to the relabelling function.

(defun relabel (G)
   (let ((H G) (mytable nil))
       (loop for x in (vertices G) do
             (if (not (member (list x x) H)) (push (list x x) H)))
       (setf mytable (translate H))
       (mapcar (lambda (edge) (mapcar (lambda (vertex) (cdr (assoc vertex mytable))) edge)) G)))
RELABEL

Here the code requires a little explanation, especially the part in which I add trivial edges of the form (list x x). This is because of the following extreme case: imagine we have a graph ((0 1) (1 2)) and we removed the vertex 1

(defparameter H '((0 1) (1 2)))
(remove-vertex 1 H)
NIL

which really is not what we want. It is better to add the trivial edges in the translation process. Now, on our graph G the function relabel returns

(relabel G)
((1 2) (2 3) (0 3) (3 4))