> I have a class heirarchy resembling the following:
>
> (define-class <a> () ())
> (define-class <b> () ())
> (define-class <c> (<b>) ())
> (define-class <d> (<c> <a>) ())
>
> (define-method m ((self <a>)) (display "I'm an <a>") (newline))
> (define-method m ((self <b>)) (display "I'm a <b>") (newline))
>
> Now if I create a <c> and a <d> and pass them to m:
>
> (m (make <c>))
> (m (make <d>))
>
> I see
>
> I'm a <b>
> I'm an <a>
>
> It seems to me that d should be a <b>, because <c> comes before <a>
> in the definition of <d>, and <b> should come before <a> because CLOS
> is supposed to keep the <c> family tree together. Isn't this right?
It is not a bug. It's only that things are not identical that in CLOS.
I don't know what algorithm is more logical". In your exemple, I'm enclained
to think that the CLOS algorithm is better .However, in the exemple which is
exhibited in the Annex of the STk reference manual the STklos algorithm seems
to me better. In AMOP (p 80 if I remeber), there are 2 other class precedence
list which are shown with different results. I think that no solution is
ideal. The important thing is that the algorithm is known by advance (and that
it is deterministic:-> ).
Note however, that if you want to change the algorithm which buid the class
precedence list, you only have to redefine the compute-cpl function (whih is
defined in the file STklos/stklos.stk). The code in this function is
(define (compute-cpl class)
(define (filter-cpl class)
(let ((res '()))
(for-each (lambda (item)
(unless (or (eq? item <object>)
(eq? item <top>)
(member item res))
(set! res (cons item res))))
class)
res))
(let* ((supers (slot-ref class 'direct-supers))
(big-list (apply append (cons class supers)
(map compute-cpl supers))))
(reverse (list* <top> <object> (filter-cpl big-list)))))
which is relatively simple. I have preferred to rewrite (and change) the class
precedence list algorrithm since
- the CLOS algorithm has somtimes a "weird" behaviour (imho)
- the only implementation I know in Scheme of the CLOS algorithm is
the one we can find in Tiny Clos (and that I have never tried to
understand, but which seems not simple).
- in case of doubt, you can always use the class-precedence-list
function to see the inheritance precedence list
The Tiny Clos algorithm is given below if you want to adapt it to
STklos.
;
; A simple topological sort.
;
; It's in this file so that both TinyClos and Objects can use it.
;
; This is a fairly modified version of code I originally got from Anurag
; Mendhekar <anurag_at_moose.cs.indiana.edu>.
;
;
(define compute-std-cpl
(lambda (c get-direct-supers)
(top-sort ((build-transitive-closure get-direct-supers) c)
((build-constraints get-direct-supers) c)
(std-tie-breaker get-direct-supers))))
(define top-sort
(lambda (elements constraints tie-breaker)
(let loop ((elements elements)
(constraints constraints)
(result '()))
(if (null? elements)
result
(let ((can-go-in-now
(filter-in
(lambda (x)
(every (lambda (constraint)
(or (not (eq? (cadr constraint) x))
(memq (car constraint) result)))
constraints))
elements)))
(if (null? can-go-in-now)
(error 'top-sort "Invalid constraints")
(let ((choice (if (null? (cdr can-go-in-now))
(car can-go-in-now)
(tie-breaker result
can-go-in-now))))
(loop
(filter-in (lambda (x) (not (eq? x choice)))
elements)
;(filter-in (lambda (x) (not (eq? (cadr x) choice)))
; constraints)
constraints
(append result (list choice))))))))))
(define std-tie-breaker
(lambda (get-supers)
(lambda (partial-cpl min-elts)
(let loop ((pcpl (reverse partial-cpl)))
(let ((current-elt (car pcpl)))
(let ((ds-of-ce (get-supers current-elt)))
(let ((common (filter-in (lambda (x)
(memq x ds-of-ce))
min-elts)))
(if (null? common)
(if (null? (cdr pcpl))
(error 'std-tie-breaker "Nothing valid")
(loop (cdr pcpl)))
(car common)))))))))
(define build-transitive-closure
(lambda (get-follow-ons)
(lambda (x)
(let track ((result '())
(pending (list x)))
(if (null? pending)
result
(let ((next (car pending)))
(if (memq next result)
(track result (cdr pending))
(track (cons next result)
(append (get-follow-ons next)
(cdr pending))))))))))
(define build-constraints
(lambda (get-follow-ons)
(lambda (x)
(let loop ((elements ((build-transitive-closure get-follow-ons) x))
(this-one '())
(result '()))
(if (or (null? this-one) (null? (cdr this-one)))
(if (null? elements)
result
(loop (cdr elements)
(cons (car elements)
(get-follow-ons (car elements)))
result))
(loop elements
(cdr this-one)
(cons (list (car this-one) (cadr this-one))
result)))))))
-- Erick
Received on Sat Nov 19 1994 - 18:39:15 CET