#|
     XXX - Add comment what this was for and date of sources
|#

(in-package "KERNEL")

(export 'std-compute-class-precedence-list)

;;; topological-sort  --  Public.
;;;
;;; Topologically sort the list of objects to meet a set of ordering
;;; constraints given by pairs (A . B) constraining A to precede B.  When
;;; there are multiple objects to choose, the tie-breaker function is called
;;; with both the list of object to choose from and the reverse ordering built
;;; so far.
;;;
(defun topological-sort (objects constraints tie-breaker)
  (declare (list objects constraints)
	   (function tie-breaker))
  (let ((obj-info (make-hash-table :size (length objects)))
	(free-objs nil)
	(result nil))
    (dolist (constraint constraints)
      (let ((obj1 (car constraint))
	    (obj2 (cdr constraint)))
	(let ((info2 (gethash obj2 obj-info)))
	  (if info2
	      (incf (first info2))
	      (setf (gethash obj2 obj-info) (list 1))))
	(let ((info1 (gethash obj1 obj-info)))
	  (if info1
	      (push obj2 (rest info1))
	      (setf (gethash obj1 obj-info) (list 0 obj2))))))
    (dolist (obj objects)
      (let ((info (gethash obj obj-info)))
	(when (or (not info) (zerop (first info)))
	  (push obj free-objs))))
    (loop
     (flet ((next-result (obj)
	      (push obj result)
	      (dolist (successor (rest (gethash obj obj-info)))
		(let* ((successor-info (gethash successor obj-info))
		       (count (1- (first successor-info))))
		  (setf (first successor-info) count)
		  (when (zerop count)
		    (push successor free-objs))))))
       (cond ((endp free-objs)
	      (do-hash (obj info obj-info)
		(unless (zerop (first info))
		  (error "Topological sort failed due to constrain on ~S."
			 obj)))
	      (return (nreverse result)))
	     ((endp (rest free-objs))
	      (next-result (pop free-objs)))
	     (t
	      (let ((obj (funcall tie-breaker free-objs result)))
		(setf free-objs (remove obj free-objs))
		(next-result obj))))))))


;;; std-compute-class-precedence-list  --  Internal.
;;;
;;; Standard class precedence list computation.
;;;
(defun std-compute-class-precedence-list (class)
  (let ((classes nil)
	(constraints nil))
    (labels ((note-class (class)
	       (unless (member class classes)
		 (push class classes)
		 (let ((superclasses (class-direct-superclasses class)))
		   (do ((prev class)
			(rest superclasses (rest rest)))
		       ((endp rest))
		     (let ((next (first rest)))
		       (push (cons prev next) constraints)
		       (setf prev next)))
		   (dolist (class superclasses)
		     (note-class class)))))
	     (std-cpl-tie-breaker (free-classes rev-cpl)
	       (dolist (class rev-cpl (first free-classes))
		 (let* ((superclasses (class-direct-superclasses class))
			(intersection (intersection free-classes
						    superclasses)))
		   (when intersection
		     (return (first intersection)))))))
      (note-class class)
      (topological-sort classes constraints #'std-cpl-tie-breaker))))