From dta@alexandria.synquiry.com Tue Mar 24 16:12:19 1998
From: Dean T Allemang <dta@synquiry.com>
To: lieber@ccs.neu.edu
Subject: Fixed dem.lisp



Here is the dem.lisp code that I have fixed from the version that is
currently on the web.  I have put some comments at the start of this
to describe the changes.  

;;;
;;; DEM - A simple Demeter system.
;;;
;;; Modified from the BBN version by Ken Anderson
;;; Bugs fixed, March 1998, Dean Allemang, Synquiry Technologies, Ltd.
;;; 
;;; Bugs fixed:
;;; 
;;; 1. In the original, multiple paths from start to finish were not
;;;    correctly done.  In particular, if there is a valid path
;;;    leading from class A through both classes B and C, a call would
;;;    be forwarded through only one of them.  
;;;
;;; 2. Arguments were not done correctly.  If an event had arguments,
;;;    the generated calls to that method would not pass the
;;;    parameters forward; the LISP environment flags an error.
;;;
;;; 3. The utility all-superclasses did not recurse upwards; only two
;;;    levels of superclasses were returned. 
;;;
;;; 4. Some additions to make it more common-lisp friendly; 
;;;    :initforms added to slots
;;;    top-level methods to handle null values
;;;    initargs placed in keyword package
;;;


;;; Some utilities:
(defun collecting (mapper items when what how)
  (let* ((results '()))
    (funcall mapper 
             #'(lambda (a)
                 (when (funcall when a) 
                   (setq results (funcall how (funcall what a) results))))
             items)
    results))

(defmacro define-record (name &rest slots)
  (flet
    ((make-name (&rest args)
       (intern (apply #'concatenate 'string (mapcar #'string args)))))
    `(progn
       (defun ,(make-name "MAKE-" name) ,slots
         (vector ,@slots))
       ,@(mapcar #'(lambda (s) 
                     `(defun ,(make-name name "-" s) (x)
                        (svref x ,(position s slots))))
                 slots))))

;;; Globals
(defvar *classes* '() "List of names of all classes")
(defvar *events* '() "List of events.")

;;; Records
(define-record arc source label target list?)

;;; Slot -> (<name> <type>) | (<name> (list <type>))
(defun slot-name (slot) (car slot))
(defun slot-list? (slot) (and (consp (cadr slot)) (eq (car (cadr slot)) 'list)))
(defun slot-type (slot) (cadr (if (slot-list? slot) (cadr slot) slot)))

;;; A method aka THOD.
(define-record thod name class args body)

(define-record dem-class name supers slots)

(defun find-dem-class (name) (find name *classes* :key #'dem-class-name))
28
(defun add-dem-class (class)
  (setq *classes* 
        (cons class (delete (dem-class-name class) *classes* 
                      :key #'dem-class-name))))

(defun gen-dem-method (name class args body)
  `(defmethod ,name ((self ,class) ,@args)
     (flet ((,name (object) (,name object ,@args)))
       (with-slots ,(all-slot-names class) self
	 ,body)))
  )

(defun gen-dem-class (name supers slots)
  `(defclass ,name ,supers
              ,(mapcar #'(lambda (s)
                           (destructuring-bind (name type) s
                             `(,name :type ,(if (consp type) (car type) type)
                                     :initarg ,(intern name :keyword)
				     :initform nil)))
                       slots)))
43
(defmacro gen-code ()
  "Generate code for all known classes and events."
  `(progn
     ,@(mapcar #'(lambda (c) 
                   (gen-dem-class (dem-class-name c)
                                  (mapcar #'arc-target (dem-class-supers c))
                                  (mapcar #'(lambda (s)
                                              `(,(arc-label s)
                                                ,(if (arc-list? s)
                                                   `(list ,(arc-target s))
                                                   (arc-target s))))
                                  (dem-class-slots c))))
               *classes*)
     ,@(mapcan 
        #'(lambda (e) 
            `((fmakunbound ',(car e)) ,@(apply #'gen-methods e)))
        *events*)))

(defmacro define-class (name supers slots)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     ,(gen-dem-class name supers slots)
     (load-dem-class ',name ',supers ',slots)
     ,@(mapcan 
        #'(lambda (e)
            (let ((it (apply #'gen-methods-incremental e)))
              (if it `((fmakunbound ',(car e)) ,@it) '())))
        *events*)))

(defun load-dem-class (name supers slots)
  (add-dem-class 
   (make-dem-class 
    name
    (mapcar #'(lambda (super) (make-arc name nil super nil)) supers)
    (mapcar #'(lambda (slot)
                (let ((slot-name (slot-name slot))
                      (type (slot-type slot))
                      (list? (slot-list? slot)))
                  (make-arc name slot-name type list?)))
            slots))))

(defun match-flow? (pattern arc)
  (destructuring-bind (source member target) pattern
    (and (or (eq source '*) (eq source (arc-source arc)))
         (or (eq member '*) (eq member (arc-label arc)))
         (or (eq target '*) (eq target (arc-target arc))))))
84
(defun match-flows? (patterns arc)
  (some #'(lambda (pattern) (match-flow? pattern arc)) patterns))

(defun superclasses (class)
  "Direct superclasses."
  (mapcar #'arc-target (dem-class-supers (find-dem-class class))))

;(defun all-superclasses (class)
;  (if class
;    (let ((supers (superclasses class)))
;      (append supers (mapcan #'superclasses supers)))
;    '()))


; Surely, this should keep recursing until all superclasses are found -dta
(defun all-superclasses (class)
  (if class
    (let ((supers (superclasses class)))
      (append supers (mapcan #'all-superclasses supers)))
    '()))

(defun related (class)
  "Direct slots of class."
  (dem-class-slots (find-dem-class class)))

(defun all-slots (class)
  (append (mapcan #'related (all-superclasses class)) (related class)))

(defun all-slot-names (class)
  (remove-duplicates (mapcar #'arc-label (all-slots class))))
  
(defun map-superclass-arcs (f classes)
  (mapc #'(lambda (c) (mapc f (dem-class-supers c))) classes))

(defun subclasses (class)
  "List of subclasses of class, including class itself."
  (cons class (collecting #'map-superclass-arcs *classes*
                          #'(lambda (a) (eq (arc-target a) class))
                          #'(lambda (a) (subclasses (arc-source a)))
                          #'append)))

(defun path-roots (from)
  (mapcar #'list (apply #'append (mapcar #'related (subclasses from)))))

(defun grow-a-path (targets path rest)
  (if (member (arc-target (car path)) targets :test #'eq)       ; Done!
    (cons path (grow-paths targets rest))
    (let ((slots (related (arc-target (car path)))))
      (grow-paths 
       targets
       (append (collecting #'mapc slots 
                           #'(lambda (s) (not (member s path :test #'eq)))
                           #'(lambda (s) (cons s path))
                           #'cons)
               rest)))))
119
(defun grow-paths (targets paths)
  (if (consp paths) (grow-a-path targets (car paths) (cdr paths)) NIL))

(defun good-path? (path in out)
  (and (or (null in) (some #'(lambda (a) (match-flows? in a)) path))
       (or (null out) (not (some #'(lambda (a) (match-flows? out a)) path)))))

(defun load-event (name args flowspecs fragments)
  (let ((item (assoc name *events*)))
    (if item (setf (cdr item) (list args flowspecs fragments))
        (let ((item (list name args flowspecs fragments)))
          (setq *events* (cons item *events*))))))

(defun event-methods (name args flowspecs fragments)
  (let ((methods '()))
    (labels
	((find-thod (name class)
	   (find-if #'(lambda (m) (and (eq (thod-name m) name) 
				       (eq (thod-class m) class)))
		    methods))
	 (add-thod (method)
	   (setq methods
	     (cons method 
		   (delete-if 
		    #'(lambda (m) (and (eq (thod-name m) (thod-name method))
				       (eq (thod-class m) (thod-class method))))
		    methods))))
	 (append-to-thod (method)
	   (let ((old (find-thod (thod-name method) (thod-class method)))
		 )
	     (if old
		 (add-thod (make-thod
			    (thod-name method)
			    (thod-class method)
			    (thod-args method)
			    `(progn ,(thod-body method) ,(thod-body old))))
	       (add-thod method)))))
      (let* ((paths 
	      (mapcan
	       #'(lambda (spec)
		   (destructuring-bind (from to in out) spec
		     (collecting #'mapc 
				 (grow-paths to (mapcan #'path-roots from))
				 #'(lambda (p) (good-path? p in out))
				 #'identity #'cons)))
	       flowspecs))
	     (arcs (remove-duplicates (apply #'append paths))))
	(mapc #'(lambda (a)		; Make propagating methods.
		  (append-to-thod (make-thod name (arc-source a) args
					     (if (arc-list? a)
						 `(mapc #',name ,(arc-label a))
					       `(,name ,(arc-label a))))))
	      arcs))
      (mapc #'(lambda (f)
		(destructuring-bind (class how body) f
		  (let ((the-body  (let ((it (find-thod name class)))
				     (if it (thod-body it) '()))))
		    (add-thod (make-thod name class args
					 (ecase how
					   (= body)
					   (< `(progn ,body ,the-body))
					   (> `(progn ,the-body ,body))))))))
	    fragments))
    methods))

(defun gen-methods (name args flowspecs fragments)
  (cons `(defmethod ,name (this ,@args))
	(mapcar #'(lambda (m) 
		    (gen-dem-method (thod-name m) (thod-class m)
				    (thod-args m) (thod-body m)))
		(event-methods name args flowspecs fragments)))
  )

(let ((table (make-hash-table :test #'equal)))
  (defun gen-methods-incremental (name args flowspecs fragments)
    (let ((result (gen-methods name args flowspecs fragments)))
      (let ((key (list name args flowspecs fragments)))
        (if (equal result (gethash key table))
	    NIL
          (setf (gethash key table) result))))))

(defmacro define-event (name args flowspecs fragments)
  `(progn
     (load-event ',name ',args ',flowspecs ',fragments)
     ,@(gen-methods name args flowspecs fragments)))
186
;;; The Lisp version:
;(define-class App () ())
;(define-class Sketch (App) ((shapes (list Shape)) (mode Mode)))
;(define-class Shape  () ((x1 fixnum) (y1 fixnum) (x2 fixnum) (y2 fixnum)))
;(define-class Box (Shape) ())
;(define-class Line (Shape) ((a fixnum) (b fixnum)))
;(define-class Text (Shape) ((string string)))
;
;(define-class Mode () ((sketch Sketch) (next Mode)))
;(define-class Gesture (Mode) ((shape Shape) (origin Point)))
;(define-class Drag (Mode) ((shapes (list Shape)) (knob fixnum)))
;(define-class Gather (Mode)
;  ((points (list point)) (x1 fixnum) (y1 fixnum) (x2 fixnum) (y2 (fixum))))
;
;(define-event draw ()
;  (((Sketch) (Shape) () ((* mode *)))
;   )
;  (
;   (Line = (progn (move x1 y1) (line x2 y2) (arrow a 0) (arrow b 1)))
;   (Box = (progn (move x1 y1) (line x1 y2) (line x2 y2) (line x2 y1) (line x1 y1)))
;   (Text = (progn (move x1 y1) (text string)))
;   ))
;
;(defun move (x y) (print (list 'move x y)))
;(defun line (x y) (print (list 'line x y)))
;(defun text (s) (print (list 'text s)))
;(defun arrow (x y) (print (list 'arrow x y)))
;
;(defun make-one ()
;  (let ((s (make-instance 'sketch
;	     'shapes 
;	     (list 
;	      (make-instance 'box 'x1 0 'y1 10 'x2 20 'y2 40)
;	      (make-instance 'text 'x1 3 'y1 5 'string 
;			     "Frankly, my Dear, i don't give a DEM")
;	      ))))
;    s))
;
;(draw (make-one))
;