Yet another multiple inheritence problem

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)
Content-type: text/plain; charset=UTF-8
Content-transfer-encoding: 7BIT

Hi,

I'm back with yet another multiple inheritance problem (too many mixins,
I guess) ;)

My class graph looks like this:

                        eieio-default-superclass
                                   |
               +-------------------+-------------------+
               |                   |                   |
          rudel-state    rudel-impersonator    rudel-delegator
               |                   |                   |
               +-------------------+-------------------+
                                   |
                            rudel-obby-state     e-def-sup
                                   |                |
                  +----------------+                |
                  |                                 |
   rudel-obby-client-connection-state    rudel-obby-document-handler
                  |                                 |
                  +----------------+----------------+
                                   |
                  rudel-obby-client-state-subscribing

[In case the diagram gets messed up:

(defclass rudel-state ()
(defclass rudel-impersonator () 
(defclass rudel-delegator ()
(defclass rudel-obby-state (rudel-state rudel-impersonator
rudel-delegator)
(defclass rudel-obby-client-connection-state (rudel-obby-state)
(defclass rudel-obby-document-handler ()
(defclass rudel-obby-client-state-subscribing
(rudel-obby-client-connection-state rudel-obby-document-handler)

]

The problem appears with an invocation of the generic function
`no-applicable-method'. There is a method installed for
`rudel-delegator' and, of course, for `eieio-default-superclass'. I
expected the method for `rudel-delegator' to be called, since it is on
the most specific class. On second thought, the breadth-first method
resolution order cannot really do that, so the behavior is as expected.
However, I would like a different behavior better.

Despite my current problem, I think the breadth-first search may not be
optimal. A little searching yielded [1] in which the so-called C3
algorithm is described. The points made there seem very logical to me.
So much in fact, that I ported the implementation to Elisp and engaged
in some experiments. As expected, my problem could be solved, were :c3
available as a :method-invocation-order.

In my opinion, it would be very useful to include a :c3 method
resolution order in EIEIO, or even make it the default.

I attached some code to reproduce the original problem, my c3
implementation experiments and a patch that allows :c3 as
a :method-invocation-order (it is not a complete implementation,
though).

What do you think?

Kind regards,
Jan

[1] http://192.220.96.201/dylan/linearization-oopsla96.html

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)
Content-type: text/x-emacs-lisp; name=example.el; charset=UTF-8
Content-transfer-encoding: 7BIT
Content-disposition: attachment; filename=example.el

(defclass rudel-state ()
  ())

(defclass rudel-impersonator ()
  ())

(defclass rudel-delegator ()
  ())

(defclass rudel-obby-state (rudel-state rudel-impersonator rudel-delegator)
  ())

(defclass rudel-obby-client-connection-state (rudel-obby-state)
  ())

(defclass rudel-obby-document-handler ()
  ())

(defclass rudel-obby-client-state-subscribing
  (rudel-obby-client-connection-state rudel-obby-document-handler)
  ())

(defmethod no-applicable-method ((this rudel-delegator))
  ('dispatched-to-rudel-delegator))

(defgeneric no-methods (one-arg))

(let ((rocss (rudel-obby-client-state-subscribing "")))
  (no-methods rocss))


(class-all-parents 'rudel-obby-client-state-subscribing)

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)
Content-type: text/x-emacs-lisp; name=eieio-c3.el; charset=UTF-8
Content-transfer-encoding: 7BIT
Content-disposition: attachment; filename=eieio-c3.el

;;; eieio-c3.el ---
;;
;; Copyright (C) 2009 Jan Moringen
;;
;; Author: Jan Moringen <[email protected]>
;; X-RCS: $Id$
;;
;; This Program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This Program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses>.


;;; Commentary:
;;


;;; History:
;;


;;; Code:
;;
;; Note: based on:
;;   Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan
;;   Retrieved from:
;;   http://192.220.96.201/dylan/linearization-oopsla96.html

(defun eieio-c3-candidate (class remaining-inputs)
  "Returns class if it can go in the result now, otherwise false"
  ;; Ensure CLASS is not in any position but the first in any of the
  ;; element lists of REMAINING-INPUTS.
  (and (not (some (lambda (l) (member class (rest l)))
		  remaining-inputs))
       class))

(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs)
  "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
If a consistent order does not exist, signal an error."
  (if (every #'null remaining-inputs)
      ;; If all remaining inputs are empty lists, we are done.
      (nreverse reversed-partial-result)
    ;; Otherwise, we try to find the next element of the result. This
    ;; is achieved by considering the first element of each
    ;; (non-empty) input list and accepting a candidate if it is
    ;; consistent with the rests of the input lists.
    (let ((next (some (lambda (c) (eieio-c3-candidate c remaining-inputs))
		      (mapcar #'first
			      (remove-if #'null remaining-inputs)))))
      (if next
	  ;; The graph is consistent so far, add NEXT to result and
	  ;; merge input lists, dropping NEXT from their heads where
	  ;; applicable.
	  (eieio-c3-merge-lists
	   (cons next reversed-partial-result)
	   (mapcar (lambda (l) (if (eq (first l) next) (rest l) l))
		   remaining-inputs))
	;; The graph is inconsistent, give up
	(error "Inconsistent precedence graph"))))
  )

(defun eieio-class-all-parents-dfs (class)
  ""
  (let ((parents (class-parents-fast class)))
    (reverse (remove-duplicates (reverse
    (apply
     #'append
     (list class)
     (mapcar
      (lambda (parent) (cons parent (class-all-parents parent)))
      parents))))
	     )))

(defun eieio-class-all-parents-bfs (class)
  ""
  (let ((parents (class-parents-fast class)))
    (reverse (remove-duplicates (reverse
    (apply
     #'append
     (list class)
     parents
     (mapcar #'class-all-parents parents))))
	     )))

(defun eieio-class-all-parents-c3 (class)
  "Return (transitively closed) parents of CLASS in C3-order."
  (let ((parents (class-parents-fast class)))
    (eieio-c3-merge-lists
     (list class)
     (append
      (mapcar
       (lambda (x)
	 (cons x (class-all-parents x)))
       parents)
      (list parents)))))

(defun class-all-parents (class)
  "Return (transitively closed) list of parents of CLASS.
The order, in which the parents are returned depends on the
method invocation orders of the involved classes."
  (or (let ((mro (class-method-invocation-order class)))
	(rest
	 (case mro
	   (:depth-first
	    (eieio-class-all-parents-dfs class))
	   (:breadth-first
	    (eieio-class-all-parents-bfs class))
	   (:c3
	    (eieio-class-all-parents-c3 class)))))
      '(eieio-default-superclass))
  )


;;; Unit Tests
;;


;;; Grid Case
;;

(dolist (mro '(:breadth-first :depth-first :c3))

  (eval
   `(progn
      (defclass grid-layout ()
	()
	""
	:method-invocation-order ,mro)

      (defclass horizontal-grid (grid-layout)
	()
	""
	:method-invocation-order ,mro)

      (defclass vertical-grid (grid-layout)
	()
	""
	:method-invocation-order ,mro)

      (defclass hv-grid (horizontal-grid vertical-grid)
	()
	""
	:method-invocation-order ,mro)

      (defclass vh-grid (vertical-grid horizontal-grid)
	()
	""
	:method-invocation-order ,mro)

      (defclass confused-grid (hv-grid vh-grid)
	()
	""
	:method-invocation-order ,mro)))

  (condition-case err
      (progn
	(pp
	 (class-all-parents 'confused-grid)
	 #'insert)
	(when (eq mro :c3)
	  (pp '(should-error) #'insert)))
    (error (pp (list 'ok err) #'insert))))


;;; Boat Case
;;

(dolist (mro '(:breadth-first :depth-first :c3))

  (eval
   `(progn
      (defclass boat ()
	()
	""
	:method-invocation-order ,mro)

      (defclass day-boat (boat)
	()
	""
	:method-invocation-order ,mro)

      (defclass wheel-boat (boat)
	()
	""
	:method-invocation-order ,mro)

      (defclass engine-less (day-boat)
	()
	""
	:method-invocation-order ,mro)

      (defclass small-multihull (day-boat)
	()
	""
	:method-invocation-order ,mro)

      (defclass pedal-wheel-boat (engine-less wheel-boat)
	()
	""
	:method-invocation-order ,mro)

      (defclass small-catamaran (small-multihull)
	()
	""
	:method-invocation-order ,mro)

      (defclass pedalo (pedal-wheel-boat small-catamaran)
	()
	""
	:method-invocation-order ,mro)))

  (pp
   (class-all-parents 'pedalo)
   #'insert))


;;; Widget Case
;;

(dolist (mro '(:breadth-first :depth-first :c3))

  (eval
   `(progn
      (defclass choice-widget ()
	()
	""
	:method-invocation-order ,mro)

      (defclass popup-mixin ()
	()
	""
	:method-invocation-order ,mro)

      (defclass menu (choice-widget)
	()
	""
	:method-invocation-order ,mro)

      (defclass popup-menu (menu popup-mixin)
	()
	""
	:method-invocation-order ,mro)

      (defclass new-popup-menu (menu popup-mixin choice-widget)
	()
	""
	:method-invocation-order ,mro)))

  (pp
   (class-all-parents 'popup-menu)
   #'insert)
  (pp
   (class-all-parents 'new-popup-menu)
   #'insert)
  )


;;; Another Widget Case
;;

(dolist (mro '(:breadth-first :depth-first :c3))

  (eval
   `(progn
      (defclass pane ()
	()
	""
	:method-invocation-order ,mro)

      (defclass scrolling-mixin ()
	()
	""
	:method-invocation-order ,mro)

      (defclass editing-mixin ()
	()
	""
	:method-invocation-order ,mro)

      (defclass scrollable-pane (pane scrolling-mixin)
	()
	""
	:method-invocation-order ,mro)

      (defclass editable-pane (pane editing-mixin)
	()
	""
	:method-invocation-order ,mro)

      (defclass editable-scrollable-pane (scrollable-pane editable-pane)
	()
	""
	:method-invocation-order ,mro)))

  (pp
   (class-all-parents 'editable-scrollable-pane)
   #'insert)
  )

(provide 'eieio-c3)
;;; eieio-c3.el ends here

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)
Content-type: text/x-patch; name=eieio-c3.patch; charset=UTF-8
Content-transfer-encoding: 7BIT
Content-disposition: attachment; filename=eieio-c3.patch

Index: eieio.el
===================================================================
RCS file: /cvsroot/cedet/cedet/eieio/eieio.el,v
retrieving revision 1.192
diff -u -r1.192 eieio.el
--- eieio.el	19 Nov 2009 00:17:46 -0000	1.192
+++ eieio.el	8 Dec 2009 02:54:23 -0000
@@ -539,7 +542,7 @@
 
     ;; Make sure the method invocation order  is a valid value.
     (let ((io (class-option-assoc options :method-invocation-order)))
-      (when (and io (not (member io '(:depth-first :breadth-first))))
+      (when (and io (not (member io '(:depth-first :breadth-first :c3))))
 	(error "Method invocation order %s is not allowed" io)
 	))
 

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

------------------------------------------------------------------------------
Return on Information:
Google Enterprise Search pays you back
Get the facts.
http://p.sf.net/sfu/google-dev2dev

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

_______________________________________________
cedet-eieio mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/cedet-eieio

--Boundary_(ID_h0uBoWvWaaB4Ld8rEzqeeA)--