Re: Class Precedence List

[Danny Bobrow <Bobrow.pa@Xerox.COM>]

The following is my message (slightly edited to emphasize the difference
from an earlier (buggy) message), and the code Gregor and I produced for
class precedence list.


Date: 1 Dec 86 18:50 PST
Sender: Bobrow.pa
Subject: Re: Class precedence list
To: Moon@STONY-BROOK.SCRC.Symbolics.COM
Message-ID: <861201-185029-2210@Xerox>


To restate the rules I think are appropriate, they are (slightly edited
from my message of 20 October):

The class precedence list is a left to right, depth first linearization
of the transitive closure of inheritance from the local super classes of
a class.  It satisfies three constraints:

C-1) A class appears only once on the list.
C-2) The order of classes in a local supers list is preserved
C-3) A class always precedes all classes in its local supers list

It can be thought of as constructed as follows:
       1) Walk the inheritance tree in left to right depth
        first order, recording all super classes in the order visited.

        2) Remove duplicates, preserving the last occurrence
          of any class. This can be combined with step 1
          without extra consing.  This ensures that C-1 is satisfied.
          In most cases C-2 and C-3 will also be satisfied.
          This is true for all the examples in the Concepts document.

        3) Traverse the resulting list from left to right. If
        for any class c1, there is a class to its right that c1 should
        follow, move c1 to the right of the rightmost such class.
        This rightmost class must be computed by recursive application
of
        rules C-2 and C-3. (*** This recursive dependency is the
        difference between my earlier set of rules that Moon
        found buggy, and this set)  

        In computing this recursive dependency, a dependency loop may be
        discovered, indicating an error.

This algorithm gives a well defined order in which all internal
superclasses of class-1 will precede all internal superclasses of
class-2 if there is no intersection.  (*** This does provide a
topological sort of the type specified by RPG, with a preferred total
order based on the tree walk)    


Examples:

No intersection
    (DEFCLASS1 C1 ())
    (DEFCLASS1 C2 ())
    (DEFCLASS1 D1 (C1))
    (DEFCLASS1 D2 (C2))
    (DEFCLASS1 E1 (D1 D2))
After Steps 1 and 2
(E1 D1 C1 D2 C2)

Simple Intersection:
    (DEFCLASS1 C1 (OBJECT))
    (DEFCLASS1 C2 (OBJECT))
    (DEFCLASS1 D1 (C1))
    (DEFCLASS1 D2 (C2))
    (DEFCLASS1 E1 (D1 D2))
After Steps 1 and 2
(E1 D1 C1 D2 C2 OBJECT)

Moving Required:
    (DEFCLASS1 C1 ())
    (DEFCLASS1 C2 ())
    (DEFCLASS1 C3 ())
    (DEFCLASS1 D1 (C1 C2))
    (DEFCLASS1 D2 (C1 C3))
    (DEFCLASS1 E1 (D1 D2))
After Steps 1 and 2
(E1 D1 C2 D2 C1 C3)
In step 3, C2 must be moved after C1.
resulting in
(E1 D1 D2 C1 C2 C3)

Simple Error:

    (DEFCLASS1 C2 ())
    (DEFCLASS1 C3 ())
    (DEFCLASS1 D4 (C3 C2))
    (DEFCLASS1 D5 (C2))
    (DEFCLASS1 D6 (C3 C2 D5 D4))


After steps 1 and 2:

(D6 D5 D4 C3 C2) 

Now D5 needs to after C2 from D6 definition.  Computing the recursive
closure of the constraints on D5, we see that C2 must be after D4 from
D4, and D4 must be after D5 from D6!!! Error.  

Complex Constraint

    (DEFCLASS1 E1 (C1))
    (DEFCLASS1 E2 (C2))
    (DEFCLASS1 E3 (C3))
    (DEFCLASS1 E4 (E3 E2 E1))
    (DEFCLASS1 E5 (C1 C2))
    (DEFCLASS1 E6 (C2 C3))
    (DEFCLASS1 E7 (E5 E6 E4))

After Steps 1 and 2

(E7 E5 E6 E4 E3 C3 E2 C2 E1 C1)
In Step 3
  C3 has to be after C2 from E6, and hence after C1 from E5, giving
(E7 E5 E6 E4 E3 E2 C2 E1 C1 C3)
Now C2 is next in the list and it moves past C1 from E5, giving
(E7 E5 E6 E4 E3 E2 E1 C1 C2 C3).


Date: Tue, 2 Dec 86 16:11 PST
From: Gregor.pa
Subject: code for compute-class-precedence-list
To: Common-Lisp-Object-System@Sail.Stanford.edu
Message-ID: <861202161119.4.GREGOR@AVALON.isl.parc.xerox.com>
Line-fold: no


Here is the code and some examples for the latest version of
compute-class-precedence-list as described by Danny yesterday.

At the end are some examples.

(DEFMACRO DEFCLASS1 (NAME SUPERCLASSES)
  `(progn (setf (get ',name 'supers) ',superclasses)))

(defun compute-class-precedence-list (root)
  (let ((cpl ())
	(must-precede-alist ()))
    ;; We start by computing two values.
    ;;   CPL
    ;;     The depth-first left-to-right up to joins walk of the supers
tree.
    ;;   MUST-PRECEDE-ALIST
    ;;     An alist of the must-precede relations. The car of each
element of the
    ;;;    must-precede-alist is a class, the cdr is all the classes
which must
    ;;     precede that class in the CPL.
    ;;
    ;; Note that the actual walk is breadth-first, right-to-left.
    ;;
    (labels ((walk-supers (class &optional precedence)
	       (let ((elem (assoc class must-precede-alist)))
		 (if elem
		     (setf (cdr elem) (union (cdr elem) precedence))
		     (push (cons class precedence) must-precede-alist)))
	       (let* ((rsupers (reverse (cons class (get class 'supers))))
		      (precedence (cdr rsupers)))
		 (do ((sup rsupers (cdr sup))
		      (pre precedence (cdr pre)))
		     ((null pre))
		   (walk-supers (car sup) pre)))
	       (unless (member class cpl) (push class cpl)))
	     (must-move-p (element list &aux move)
	       (dolist (must-precede (cdr (assoc element must-precede-alist)))
		 (when (setq move (member must-precede (cdr list)))
		   (return move))))
	     (find-farthest-move (element move)
	       (let ((closure (compute-must-precedes-closure element)))
		 (dolist (must-precede closure)
		   (setq move (or (member must-precede move) move)))
		 move))
	     (compute-must-precedes-closure (class)
	       (let ((closure ()))
		 (labels ((walk (element path)
			    (when (member element path)
			      (class-ordering-error
				root element path must-precede-alist))
			    (dolist (precede (cdr (assoc element must-precede-alist)))
			      (pushnew precede closure)
			      (walk precede (cons element path)))))
		   (walk class nil)
		   closure))))
      (walk-supers root)			;Do the walk
      ;; For each class in the cpl, make sure that there are no classes
after it which
      ;; should be before it.  We do this by cdring down the list,
making sure that for
      ;; each element of the list, none of its must-precedes come after
it in the list.
      ;; If we find one, we use the transitive closure of the
must-precedes (using
      ;; find-farthest-move) to see where the class must really be
moved. We use a
      ;; hand-coded loop so that we can splice things in and out of the
CPL as we go.
      (let ((tail cpl)
	    (element nil)
	    (move nil))
	(loop (when (null tail) (return))
	      (setq element (car tail)
		    move (must-move-p element tail))
	      (cond (move
		     (setq move (find-farthest-move element move))
		     (setf (cdr move) (cons element (cdr move)))
		     (setf (car tail) (cadr tail));OK to use Interlisp delete trick
since it
		     (setf (cdr tail) (cddr tail));will never be the last element of
the list.
		     )
		    (t
		     (setq tail (cdr tail)))))
	(copy-list cpl)))))

(defun class-ordering-error (root element path must-precede-alist)
  (declare (ignore root))
  (setq path (cons element (reverse (member element (reverse path)))))
  (let ((explanations ()))
    (do ((tail path (cdr tail)))
	((null (cdr tail)))
      (let ((after (cadr tail))
	    (before (car tail)))
	(if (member after (get before 'supers))
	    (push (format nil "~% ~A must precede ~A -- ~A is in the local
supers of ~A."
			  before after after before)
		  explanations)
	    (dolist (common-precede (intersection
				      (cdr (assoc after must-precede-alist))
				      (cdr (assoc before must-precede-alist))))
	      (when (member after (member before (get common-precede 'supers)))
		(push (format nil "~% ~A must precede ~A -- ~A has local supers ~S."
			      before after
			      common-precede
			      (get common-precede 'supers))
		      explanations))))))
    (error "While computing the class-precedence-list for the class
~A:~%~
             There is a circular constraint through the classes:~{
~A~}.~%~
             This arises because:~{~A~}"
	   root path (reverse explanations))))



;;;; Examples
(defclass1 o ())
(defclass1 b1 (o))
(defclass1 b2 (o))
(defclass1 b3 (o))
(defclass1 b4 (o))
(defclass1 ex1-1 (b1 b3 b4))
(defclass1 ex1-2 (b2 b3))
(defclass1 example-1 (ex1-1 ex1-2))

(equal (compute-class-precedence-list 'example-1)
       '(EXAMPLE-1 EX1-1 B1 EX1-2 B2 B3 B4 O))

(defclass1 o ())
(defclass1 b1 (o))
(defclass1 b2 (o))
(defclass1 b3 (o))
(defclass1 ex2-1 (b1))
(defclass1 ex2-2 (b2))
(defclass1 ex2-3 (b3))
(defclass1 example-2 (ex2-1 ex2-2 ex2-3))

(equal (compute-class-precedence-list 'example-2)
       '(EXAMPLE-2 EX2-1 b1 EX2-2 b2 EX2-3 b3 O))


(DEFCLASS1 C1 ())
(DEFCLASS1 C2 ())
(DEFCLASS1 C3 ())
(DEFCLASS1 C4 (C1 C2))
(DEFCLASS1 C5 (C3 C2))
(DEFCLASS1 C6 (C4 C5))

(equal (compute-class-precedence-list 'c6)
       '(C6 C4 C1 C5 C3 C2))

(DEFCLASS1 E1 (c1))
(DEFCLASS1 E2 (c2))
(DEFCLASS1 E3 (c3))
(DEFCLASS1 E4 (E3 E2 E1))
(DEFCLASS1 E5 (c1 c2))
(DEFCLASS1 E6 (c2 c3))
(DEFCLASS1 E7 (E5 E6 E4))

(equal (compute-class-precedence-list 'e7)
       '(e7 e5 e6 e4 e3 e2 e1 c1 c2 c3))


(defclass1 d0 ())
(defclass1 d1 ())
(defclass1 d2 ())
(defclass1 d3 ())
(defclass1 e (d0 d1))
(defclass1 f (d1 d2 d3))
(defclass1 g (d1 d2))
(defclass1 h (d0))
(defclass1 foo (e f g h))

(equal (compute-class-precedence-list 'foo)
       '(foo e f g h d0 d1 d2 d3))


(DEFCLASS1 D1 ())
(DEFCLASS1 D2 ())
(DEFCLASS1 D3 ())
(DEFCLASS1 D4 (D3 D2))
(DEFCLASS1 D5 (D2))
(DEFCLASS1 D6 (D3 D2 D5 D4))

(COMPUTE-CLASS-PRECEDENCE-LIST 'D6)		;should error



(defclass1 g1 ())
(defclass1 g2 ())
(defclass1 g3 ())
(defclass1 g4 ())
(defclass1 g5 (g1 g2))
(defclass1 g6 (g2 g3))
(defclass1 g7 (g3 g4))
(defclass1 g8 (g4 g5 g6 g7))

(compute-class-precedence-list 'g8)		;should error