;-*-Mode:LISP; Package: User; Base:10; Syntax:Common-lisp -*-
;
;
; **********************************************************************
; Copyright (c) 1992, 1993 Xerox Corporation.  
; All Rights Reserved.  
;
; Use, reproduction, and preparation of derivative works are permitted.
; Any copy of this software or of any derivative work must include the
; above copyright notice of Xerox Corporation, this paragraph and the
; one after it.  Any distribution of this software or derivative works
; must comply with all applicable United States export control laws.
;
; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGES.
; **********************************************************************
;
;
;       
(in-package :user)

;
; First, the politician program, so we'll have something to type at.
;
;
(defclass <politician> ()
    (concerns))

(defclass <elected> ()
    (margin))

(defclass <senator> (<elected> <politician>)
    (state))


(defclass <manager> () ())


(defmethod initialize ((vip <politician>) &key concerns)
  (slot-set vip 'concerns concerns))

(defmethod initialize ((vip <elected>) &key margin)
  (slot-set vip 'margin margin))

(defmethod initialize ((vip <senator>) &key state)
  (slot-set vip 'state state))


(defgeneric     concerns (pol))
(defgeneric set-concerns (pol new))

(defgeneric       margin (pol))
(defgeneric   set-margin (pol new))

(defgeneric        state (pol))
(defgeneric    set-state (pol new))



(defgeneric vote (who issue))

(defmethod vote ((who <politician>) issue)      ;Cheap approximation of
  'yes)                                         ;do the popular thing

(defmethod vote ((who <manager>) issue)         ;Cheap approximation of
  'no)                                          ;the cost-effective thing.



;
; III-14
; Finding all Subclasses
;
;
(defun subclasses (class)
  (remove-duplicates
    (cons class
          (mapappend #'subclasses
                     (class-direct-subclasses class)))))

(defun all-classes ()
  (subclasses (find-class '<object>)))



;
; III-19
; Slot Geneology
;
;
(defun slot-geneology (class slot-name)
  (slot-geneology-1 (class-cpl class) slot-name))

(defun slot-geneology-1 (cpl slot-name)
  (if (member slot-name (class-direct-slots (first cpl)))
      (class-name (first cpl))
      (slot-geneology-1 (rest cpl) slot-name)))

;
; III-27
; Average Number of Methods on GFs
;
;
(defun all-gfs ()
  (remove-duplicates
    (mapappend #'class-direct-gfs (all-classes))))

(defun class-direct-gfs (class)
  (mapcar #'method-gf (class-direct-methods class)))

(defun all-methods ()
  (mapappend #'class-direct-methods (all-classes)))


;
; III-30
; Robot Complexity
;
;
(defun robot-complexity-a (class gfs)
  (let ((methods (mapappend #'gf-methods gfs)))
    (count-if #'(lambda (m)
                  (eq (method-specializer m) class))
              methods)))


(defun robot-complexity-b (class gfs)
  (let ((methods (mapappend #'gf-methods gfs)))
    (count-if #'(lambda (m)
                  (member (method-specializer m)
                          (class-cpl class)))
              methods)))


;
; III-50
; Going to the Zoo
;
;
(defclass <animal> ()())

(defclass <giraffe> (<animal>)
    (long-necked tree-eating salt-licking))
  
(defclass <bunny> (<animal>)
    (soft coddly shy))

(defclass <bear> (<animal>)
    (carnivorous predatory speedy))

(defclass <bearunny> (<bear> <bunny>)
    ())

(defclass <bearunnyraffe> (<giraffe> <bearunny>)
    ())

(defun make-animals (class)
  (mapcar #'*make (&subclasses class)))


;(make-animals (find-class '<bear>))  --> 3 animals


;
; III-61 More Problems at the Zoo
;
;
(defgeneric make-noise (animal))

(defmethod make-noise ((b <bear>))
  (flet ((open-mouth ())
         (generate-growl ()
           (format t "Grrrrrr")))
    (open-mouth)
    (generate-growl)))


(defun display-behaviors (animal)
  (let* ((class (class-of animal))
         (cpl (class-cpl class))
         (possible-gfs
           (remove-duplicates 
             (mapappend #'class-direct-gfs cpl)))
         (focused-gfs
           (remove-if-not
             #'(lambda (gf)
                 (and (null (cdr (gf-arglist gf)))      ;One argument gf?
                      (some #'(lambda (m)
                                (member (find-class '<animal>)
                                        (class-cpl (method-specializer m))))
                            (gf-methods gf))))
             possible-gfs)))
    (mapcar #'(lambda (gf)
                (*apply-gf gf (list animal)))
            focused-gfs)))


;(display-behaviors (make <bear>))  -->  The bear Growls...



;
; III-68 Buying a Car
;
;
(defclass <color> () (finish hue))
(defclass <blue> (<color>) (pigment-density))
(defclass <red>  (<color>) (paint-supplier))

(defclass <option> () (price availability))
(defclass <4-wheel> (<option>) (ovrdrve))
(defclass <radio>   (<option>) (presets scan))

(defclass <manufacturer> () (backlog rebates))
(defclass <ford>  (<manufacturer>) (plant))
(defclass <mazda> (<manufacturer>) (branch))

(defun generate-order (wish-list)
  (let* ((supers (mapcar #'find-class wish-list))
         (class (make <class>
                      :direct-supers supers
                      :direct-slots '())))
    (*make class)))


;(generate-order '(<blue> <radio> <mazda>))

;
;  III-83 Class Library Contractors
;
;
(defclass <authored-class> (<class>)
    (author))

(defmethod initialize ((class <authored-class>) &key author)
  (call-next-method)
  (slot-set class 'author author))

(defun class-author (class)
  (slot-ref class 'author))

(make <authored-class>
      :name '<communications-device>
      :direct-supers '()
      :direct-slots '()
      :author 'Bill)

(defclass <phone> (<communications-device>)  
    ()
  :class <authored-class>
  :author 'Fred)


;(class-author (find-class '<communications-device>))  --> BILL
;(class-author (find-class '<phone>))                  --> FRED




;
;  III-90 Counting Classes
;
;
(defclass <counted-class> (<class>)
    (counter))

(defmethod initialize ((class <counted-class>) &key)
  (call-next-method)
  (slot-set class 'counter 0))

(defun instance-count (name-of-class)
  (slot-ref (find-class name-of-class) 'counter))

(defmethod *make ((class <counted-class>))
  (let ((instance (call-next-method)))
    (slot-set class 'counter (1+ (slot-ref class 'counter)))
    instance))


(defclass <order> ()
     (amount)
  :class <counted-class>)


;(instance-count '<order>)   --> 0
;
;(make <order>)
;
;(instance-count '<order>)   --> 1



;
; III-111 Class Precedence Lists
;
;
(defclass <a> () ())
(defclass <b> () ())
(defclass <c> () ())
(defclass <s> (<a> <b>) ())
(defclass <r> (<a> <c>) ())
(defclass <q> (<s> <r>) ())

(defclass <flavors-class> (<class>) ())
(defclass <loops-class>   (<class>) ())

(defmethod *compute-cpl ((c <flavors-class>))
  <<<do-the-right-thing>>>)

(defmethod *compute-cpl ((c <loops-class>))
  <<<do-the-right-thing>>>)


;
; III-133 Lazy Slots
;
;
(defclass <lazy-class> (<class>)
    (lazy-slots))

(defmethod initialize ((class <lazy-class>) &key lazy-slots)
  (call-next-method)
  (slot-set class 'lazy-slots lazy-slots))

(defun fetch-from-file (file-name)
  `(from-file ,file-name))


(setq *slot-access-protocol* ':original)

(defmethod *slot-ref ((class <lazy-class>) object slot-name)
  (let ((entry
          (assoc slot-name
                 (slot-ref class 'lazy-slots))))
    (if (null entry)                            
        (call-next-method)                      ;NOT a lazy slot
        (or (call-next-method)                  ;IS  a lazy slot
            (slot-set
              object
              slot-name
              (fetch-from-file (second entry)))))))


(defclass <truck> ()
    (front side weight)
  :class <lazy-class>
  :lazy-slots '((front "/images/truck.front")
                (side  "/images/truck.side")))


;(setq tr1 (make <truck>))   -->  #<<truck> n>
;(slot-ref tr1 'side)        -->  (FROM-FILE "/images/truck.side")



;
; III-144 Slot attributes
;
;
(defclass <attributes-class> (<class>)
    (direct-attributes attributes))

(defmethod initialize ((c <attributes-class>)
                       &key direct-attributes)
  (call-next-method)
  (slot-set c 'direct-attributes direct-attributes)
  (slot-set c 'attributes (*compute-attributes c)))


(defgeneric class-direct-attributes (class))

(defmethod class-direct-attributes ((c <class>))
  ())

(defmethod class-direct-attributes ((c <attributes-class>))
  (slot-ref c 'direct-attributes))


(defgeneric *compute-attributes (c))

(defmethod *compute-attributes  ((c <attributes-class>))
  (let* ((cpl (class-cpl c))
         (attributes
           (remove-duplicates
             (mapappend #'class-direct-attributes cpl)
             :test #'equal)))
    (mapcar #'(lambda (attribute)
                (list attribute (*allocate-location c)))
            attributes)))


(defun attribute-ref (object slot attribute)
  (*attribute-ref (class-of object)
                  object
                  slot
                  attribute))

(defun attribute-set (object slot attribute new-value)
  (*attribute-set (class-of object)
                  object
                  slot
                  attribute
                  new-value))


(defgeneric *attribute-ref (c object slot attribute))
(defgeneric *attribute-set (c object slot attribute new-value))


(defmethod *attribute-ref ((c <attributes-class>)
                           object
                           slot
                           attribute)
  (let ((entry (assoc (list slot attribute)
                      (slot-ref c 'attributes)
                      :test #'equal)))
    (if (null entry)
        (error "No such attribute.")
        (%object-ref object (second entry)))))

(defmethod *attribute-set ((c <attributes-class>)
                           object
                           slot
                           attribute
                           new-value)
  (let ((entry (assoc (list slot attribute)
                      (slot-ref c 'attributes)
                      :test #'equal)))
    (if (null entry)
        (error "No such attribute.")
        (%object-set object (second entry) new-value))))


(defclass <rating> ()
    (name level)
  :class <attributes-class>
  :direct-attributes '((level date-set)
                       (level who-set)))


;(setq cr (make <rating>))
;(slot-set cr 'level 3000)
;(attribute-set cr 'level 'date-set "9/27")

;(slot-ref cr 'level)
;(attribute-ref cr 'level 'date-set)



;
; IV-3 Dynamic Slots
;
;
(defclass <dynamic-class> (<class>)
    (dval-loc))

(defmethod initialize ((c <dynamic-class>) &key)
  (call-next-method)
  (slot-set c 'dval-loc (*allocate-location c)))

(defmethod *compute-slots ((c <dynamic-class>))
  (let* ((cpl (class-cpl c))
         (all-slot-names
           (remove-duplicates
             (mapappend #'class-direct-slots cpl))))
    (mapcar #'(lambda (slot-name)
                (list slot-name
                      (if (slot-should-be-dynamic? c slot-name)
                          :dynamic
                          (*allocate-location c))))
            all-slot-names)))

(defun slot-should-be-dynamic? (class slot-name)
  (let ((class-defined-in
          (find-if #'(lambda (c)
                       (member slot-name (class-direct-slots c)))
                   (class-cpl class))))
    (and class-defined-in                       ;??? What is this for?
         (eq (class-of class-defined-in)
             (find-class '<dynamic-class>)))))


(defmethod *slot-ref ((class <dynamic-class>) object slot-name)
  (if (dynamic-slot-p class slot-name)
      (let* ((dval-loc (slot-ref class 'dval-loc))
             (dvalues (%object-ref object dval-loc))
             (entry    (assoc slot-name dvalues)))
        (and entry (second entry)))
      (call-next-method)))

(defmethod *slot-set ((class <dynamic-class>) object slot-name new-value)
  (if (dynamic-slot-p class slot-name)
      (let* ((dval-loc (slot-ref class 'dval-loc))
             (dvalues  (%object-ref object dval-loc))
             (entry    (assoc slot-name dvalues)))
        (if entry
            (setf (second entry) new-value)
            (%object-set object
                         dval-loc
                         (cons (list slot-name new-value)
                               dvalues)))
        new-value)
      (call-next-method)))


(defun dynamic-slot-p (class slot-name)
  (let* ((slots (class-slot-locations class))
         (slot (assoc slot-name slots)))
    (eq (second slot) :dynamic)))


(defclass <place> ()
    (country city hospital))

(defclass <person> ()
    (place-of-birth age vitamin-A
     vitamin-B
     vaccinations)
  :class <dynamic-class>)


;(setq person1 (make <person>))
;
;(slot-ref person1 'age)       -->  NIL
;(slot-set person1 'age 30)
;(slot-ref person1 'age)       -->  NIL



;
; Dynamic Slots With Curried Slot Access Protocol
;
;
(defmethod *slot-ref-residual ((c <dynamic-class>) slot-name)
  (if (dynamic-slot-p c slot-name)
      (let ((dval-loc (slot-ref c 'dval-loc)))
        #'(lambda (object)
            (second (assoc slot-name (%object-ref object dval-loc)))))
      (call-next-method)))

(defmethod *slot-set-residual ((class <dynamic-class>) slot-name)
  (if (dynamic-slot-p class slot-name)
      (let* ((dval-loc (slot-ref class 'dval-loc)))
        #'(lambda (object new-value)
            (let* ((dvalues  (%object-ref object dval-loc))     
                   (entry    (assoc slot-name dvalues)))
              (if entry
                  (setf (second entry) new-value)
                  (%object-set object
                               dval-loc
                               (cons (list slot-name new-value)
                                     dvalues)))
              new-value)))
      (call-next-method)))


(setq *slot-access-protocol* ':curried)         ;Tell Tiny CLOS to turn on
                                                ;the curried protocol.

(defclass <person> ()
    (place-of-birth age vitamin-A
     vitamin-B
     vaccinations)
  :class <dynamic-class>)


;(setq person2 (make <person>))

;(slot-ref person2 'age)       -->  NIL
;(slot-set person2 'age 30)
;(slot-ref person2 'age)       -->  NIL