;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun May 21 12:37:16 2006 +0530 <enometh@meer.net>
;;;   Time-stamp: <06/05/22 00:22:38 madhu>
;;;
;;; Tsort algoritm from Michael Rendell's tsort.c

(defpackage "TSORT" (:use "CL"))
(in-package "TSORT")

;;
;; GRAPH REPRESENTATION
;;
;; G=(V,E) = alist ((source-node . adjacencies) ...)  adjacencies are
;; a list of target-nodes such that an edge from source-node to
;; target-node exists. Nodes are compared with EQL
;;
;; In canonical form, there are no duplicate edges and V = (mapcar
;; #'car graph).

 
(defun canonicalize-graph (graph)
  "Non destructive version. Remove duplicates in adjacencies
i.e. remove duplicate edges. If v appears in the adjacencies of
some node but has no adjacencies, add an empty adjacency list for
v, Collapse multiple adjacency lists. Returns as values the new
graph and a hashtable of target nodes and their in-degrees."
  (let ((v1 (make-hash-table))		; sources
	(v2 (make-hash-table))		; targets
	new-graph)
    (loop for l in  graph for (source . adjacencies) = l do
	  (setq adjacencies (remove-duplicates adjacencies))
	  (cond ((gethash (setq source (car l)) v1)
		 (let* ((x (assoc source new-graph)))
		   (setq adjacencies (remove-if (lambda (a)
						  (find a (cdr x)))
						adjacencies))
		   (setf (cdr x) (nconc (cdr x) adjacencies))))
		(t (push (cons source adjacencies) new-graph)
		   (setf (gethash source v1) t)))
	  (loop for v in adjacencies do (incf (gethash v v2 0))))
    (loop for v being each hash-key of v2 unless (gethash v v1)
	  do (push (list v) new-graph) #+dbg (setf (gethash v v1) t))
    #+dbg
    (assert (= (hash-table-count v1) (length graph)))
    (values new-graph v2)))


#+nil
(canonicalize-graph (copy-tree '((1 2) (1 3) (2 3) (3 4) (1 4) (5 6) (7 10))))


(defvar $v2)
(defparameter $g1 '((1 2 3 4)
		    (2 3)
		    (3 4)
		    (4)
		    (5)))

#+nil
(multiple-value-setq ($g1 $v2)
      (canonicalize-graph '((1 2 3 4 3 4) (13)
			    (2 4 7 9)
			    (1 2)
			    (10)
			    (7 10)
			    (1 3)
			    (3 7 6)
			    (1 9))))

(defun V (graph)
  "Return a list of (vertex) nodes in our canonical adjacency
list representation of GRAPH."
  (mapcar #'car graph))


#+nil
(V $g1)


(defun E (graph)
  "Return a list of edges (arcs) in our canonical adjacency list
representation of GRAPH. Edges are represented as a (cons SOURCE
TARGET)"
  (loop for (node . adjacencies) in graph
	nconc (mapcar (lambda (x) (cons node x)) adjacencies)))

#+nil
(E $g1)

(defun adjacencies (graph node)
  (cdr (assoc node graph)))

#+nil
(adjacencies $g1 1)

(defun clear-cycle (graph flags)
  "TSORT INTERNAL. Clears the NODEST flag from all nodes."
  (loop for (node . adjacencies) in graph
	do (setf (gethash node flags)
		 (delete :nodest (gethash node flags) :test #'eq))))

(defun find-cycle (graph source target longest-length depth longest-p flags
		   &optional cycle-buf)
  "TSORT INTERNAL. Look for a cycle from SOURCE to TARGET.
If LONGEST-P is non-nil try to find the longest cycle.  FLAGS is
a hash-table of nodes and their properties."
  (declare (special *longest-cycle*))
  (loop for x in (gethash source flags) do
	(case x ((:nodest :mark :acyclic) (return-from find-cycle 0))))
  (push :mark (gethash source flags))
  (loop for np in (adjacencies graph source) do
	(cond ((eql np target)
	       (when (> (1+ depth) longest-length)
		 (setq longest-length (1+ depth))
		 (setq *longest-cycle* (cons np cycle-buf))))
	      ((loop for x in (gethash source flags) do
		     (case x ((:nodest :mark :acyclic) (return t))))
	       (let ((len (find-cycle graph np target longest-length
				      (1+ depth)
				      longest-p
				      flags
				      (cons np cycle-buf))))
		 (when (zerop len)  (pushnew :nodest (gethash np flags)))
		 (when (> len longest-length) (setq longest-length len))
		 (when (and (> len 0) (not longest-p)) (return))))))
  (setf (gethash source flags) (delete :mark (gethash source flags)))
  longest-length)


(define-condition cycle-exists (error)
  ((longest-cycle :initarg :longest-cycle :initform nil
		  :reader cycle-longest-cycle))
  (:report (lambda (condition stream)
	     (format stream "Cycle detected: ~A"
		     (cycle-longest-cycle condition)))))


(defun tsort (g &key if-cycle-exists (longest-p t)
	      collect collect-cycles  &aux
	      (flags (make-hash-table)) *longest-cycle* result cycles)
  "If IF-CYCLE-EXISTS is NIL or :SOFT, keep going on encountering a cycle.
If :ERROR, raise a continuable CYCLE-EXISTS condition. If :STOP,
stop immediately and return the cycle. (Note the special case
semantics.) If :COLLECT, automatically enable the COLLECT-CYCLES
keyword argument, collect the cycle and return it in the second
value.

If LONGEST-P is Non-NIL, look for the longest cycle.

If COLLECT is non-NIL or :REVERSE Return a topological ordering,
or its reverse as primary value. The second value is non-NIL if
cycles were encountered. If COLLECT-CYCLES is NON-NIL, the second
value is the list of cycles."
  (declare (special *longest-cycle*))
  (when (eq if-cycle-exists :collect)
    (unless collect-cycles (setq collect-cycles t)))
  (multiple-value-bind (graph v2) (canonicalize-graph g)
    (loop (if (endp graph)
	      (return (ecase collect
			(:reverse (values result cycles))
			('nil (if collect-cycles (values nil cycles)))
			('t (values (nreverse result) cycles)))))
       (when (zerop (loop for node in (V graph)
			  for l = (assoc node graph)
			  for (source . adjacencies) = l
			  when (zerop (gethash source v2 0))
			  do (loop for target in (cdr l)
				   do (decf (gethash target v2 0)))
			  (setq graph (delete l graph))
			  #+dbg
			  (warn "~A" source)
			  (when collect (push source result))
			  and count 1))
	 (loop for source in (V graph) for l = (assoc source graph) do
	       (unless (find :acyclic (gethash source flags))
		 (let ((count (find-cycle graph source source 0 0
					  longest-p flags)))
		   (cond ((> count 0)
			  #+dbg
			  (warn "node ~A: Cycle in data: ~A" source
				*longest-cycle*)
			  (ecase if-cycle-exists
			    (:error (cerror "Continue" 'cycle-exists
					   :longest-cycle *longest-cycle*))
			    (:stop (return-from tsort *longest-cycle*))	; XXX
			    ((:soft nil :keep-going :collect)))
			  (if collect-cycles
			      (push *longest-cycle* cycles)
			      (unless cycles (setq cycles t)))
			  (loop for target in (cdr l) do
				(decf (gethash target v2 0)))
			  (setq graph (delete l graph))
			  (clear-cycle graph flags) ; break from loop
			  (return))
			 ((= count 0)	; avoid further checks
			  (pushnew :acyclic (gethash source flags))
			  (clear-cycle graph flags))
			 (t (error "internal error: bad-find-cycle"))))))))))
	 

#+nil
(tsort '((1 2)
	 (1 3)
	 (1 1)
	 (2 3 4 5)
	 (3 4)
	 (42 666 123)
	 (666 123)
	 (666 42)
	 (4 3))
       :if-cycle-exists :error :collect-cycles t :collect t)

#+nil
(defparameter $g2 (canonicalize-graph
		   (copy-tree '((1 2 3 1)
				(2 3 4 5)
				(3 4)
				(42 666 123)
				(666 123)
				(4 3)))))
#+nil
(tsort $g2)

#+nil
(multiple-value-setq ($g2 $v2)
  (canonicalize-graph '((1 2)
			(1 3)
			(1 1)
			(2 3 4 5)
			(3 4)
			(42 666 123)
			(666 123)
			(666 42)
			(4 3))))

#+nil
(multiple-value-setq ($tsort $cycles) (tsort $g2))


(defun delete-edge (graph source target &optional v2)
  "V2 is a hash table of target nodes and their in-degrees"
  (let ((x (assoc source graph)))
    (when (cdr x)				; (cdr x) = adjacencies
      (when (cond ((eql (cadr x) target)
		   (setf (cdr x) (cddr x)) T)
		  (T (loop for prev-cons = (cdr x) then next-cons
			   for next-cons = (cdr prev-cons)
			   while prev-cons
			   when (eql (car next-cons) target) do
			   (setf (cdr prev-cons) (cdr next-cons)) (return T))))
	(when v2			;XXX
	  (let ((in-degree (decf (gethash target v2 0))))
	    #+dbg
	    (assert (>= in-degree 0))
	    (when (zerop in-degree)
	      (remhash target v2))
	    #+dbg
	    (assert (assoc target graph))))
	T))))

#+nil
(delete-edge $g1 7 10 $v2)
#+nil
(delete-edge $g1 3 7 $v2)
#+nil
(delete-edge $g1 2 7 $v2)

;;;
;;; CYCLE=  (v4 <- v3 <- v2 <- v1)
;;;
;;;

(defun remove-cycle (graph cycle &optional whole v2)
  "Destructive."
  (if (endp (cdr cycle))
      (delete-edge graph (car cycle) (car cycle) v2)
      (loop for (target source . rest) on cycle
	    for x =  (delete-edge graph source target v2) do
	    (when (null whole) (return x))
	    (when (endp rest)
	      (return (delete-edge graph (car cycle) source v2))))))

#+nil
(defparameter $g3 (copy-tree $g2))
#+nil
(remove-cycle $g3 '(1) t)
#+nil
(remove-cycle $g3 '(3 4) t)
#+nil
(remove-cycle $g3 '(666 42) $v2)


(defun remove-cycles (g &optional (graph g) v2)
  "If optional argument is specified (either as NIL or T) make a
copy."
  (case graph ((nil t)) (setq graph (copy-tree g)))
  (loop (handler-case (progn (tsort graph :if-cycle-exists :error)
			     (return graph))
	  (cycle-exists (c)
	    (warn "removing cycle ~A" (cycle-longest-cycle c))
	    (remove-cycle graph  (cycle-longest-cycle c) nil v2)))))


(defun make-random-unconnected-graph  (V E)
  "V distinct nodes, and at most E edges chosen uniformly at
random from the nodes"
  (declare (type (integer 0) V E))
  (let* ((nodes (loop for i from 1 to V collect i))
	 (a (make-array V :initial-contents nodes))
	 (graph (mapcar #'list nodes)))
    (loop repeat E do
	  (let ((source (elt a (random V)))
		(target (elt a (random V))))
	    (let ((l (assoc source graph)))
	      (pushnew target (cdr l)))))
    graph))


(defun make-random-dag (V E)
  (let ((g (make-random-unconnected-graph V E)))
    (multiple-value-bind (graph v2) (ncanonicalize-graph g)
      (remove-cycles graph graph v2))))

#+nil
(defparameter $g3 (make-random-unconnected-graph 10 20))
#+nil
(length (E $g3))
#+nil
(length $g3)
#+nil
(multiple-value-setq ($tsort $cycles)
  (tsort $g3  :if-cycle-exists :collect :collect t))

#+nil
(defparameter $g4
  (multiple-value-bind (graph v2) (canonicalize-graph $g3)
    (dolist (cycle $cycles)
      (remove-cycle graph cycle T v2))
    graph))

#+nil
(tsort $g4)

#+nil
(defparameter $g4 (make-random-dag 10 20))
#+nil
(length $g4)
#+nil
(length (E $g4))
#+nil
(tsort $g4)

#+nil
(defun check-cond (graph)
;; From: David C. Ullrich <ullrich@math.okstate.edu>
;; Subject: Re: A critic of Guido's blog on Python's lambda
;; Date: Wed, 10 May 2006 07:53:56 -0500
;; Message-ID: <ubn362tg2ft4la26hq4so0ron8lsj7fvqe@4ax.com>
;;
;; A math question the answer to which is not immediately clear to
;; me (possibly trivial, the question just ocurred to me this
;; second):
;;
;; Say G is a (finite) directed graph with no loops. Is it always
;; possible to order the vertices in such a way that
;; every edge goes from a vertex to a _previous_ vertex?
  (multiple-value-bind (tsort cycles-p) (tsort graph :collect :reverse)
    (assert (null cycles-p))
    (let ((h (make-hash-table)))
      (loop for v in tsort for i from 0 do (setf (gethash v h) i))
      (loop for (source . target) in (E graph)
	    do (assert (< (gethash target h)
			  (gethash source h)))))))

#+nil
(tsort (make-random-dag 10 20) :collect t)
#+nil
(check-cond (make-random-dag 1000 200))

#+nil
(defun in-degree-table (graph)		; utility
  (let ((h (make-hash-table)))
    (loop for (source . adjacencies) in graph do
	  (loop for target in adjacencies do
		(incf (gethash target h 0)))) h))


(defun ncanonicalize-graph (graph)
  "Destroys graph. Removes duplicates in adjacencies i.e. removes
duplicate edges. If v appears in adjacencies of some node but has
no adjacencies, add an empty adjacency list for v, Collapses
multiple adjacency lists.  Returns as values the graph and a
hashtable of target nodes and their in-degrees."
  (let ((v1 (make-hash-table))		; sources
	(v2 (make-hash-table))		; targets
	to-be-removed)
    (loop for l in  graph for (source . adjacencies) = l do
	  (cond ((gethash source v1)
		 (let ((x (assoc source graph)))
		   (setq adjacencies (delete-if (lambda (a)
						  (find a (cdr x)))
						adjacencies))
		   (setf (cdr x) (nconc (cdr x) adjacencies))
		   (push l to-be-removed))
		 (loop for v in adjacencies do (incf (gethash v v2 0))))
		(t (setf (cdr l) (delete-duplicates adjacencies))
		   (loop for v in (cdr l) do (incf (gethash v v2 0)))
		   (setf (gethash source v1) t))))
    (loop for v being each hash-key of v2 unless (gethash v v1)
	  do (push (list v) graph) (setf (gethash v v1) t))
    (loop for l in to-be-removed do (setq graph (delete l graph)))
    #+dbg
    (assert (= (hash-table-count v1) (length graph)))
	  (values graph v2)))

#+nil
(defun reverse-tsort (graph)
  "Returns as values the reverse topological sort and CYCLE-P"
  (multiple-value-bind (graph v2) (ncanonicalize-graph (copy-tree graph))
    (let (result cnt)
      (loop 
	 (setq cnt 0)
	 (loop for source in (V graph)
	       for l = (assoc source graph)
	       when (and l (zerop (gethash source v2 0))) ; in-degree is 0
	       do
	       (loop for target in (cdr l)
		     for X = (delete-edge graph source target v2)
		     do (assert X))
	       (assert (endp (cdr l)))
	       (setq graph (delete l graph))
	       (push source result)
	       (incf cnt))
	 (when (or (endp graph) (zerop cnt))
	   (return)))
      (values result graph))))

#+nil
(reverse-tsort $g1)