;;; frames.scm -- a simple frame system in Scheme. 

;;; No upward branching: each class has at most one superclass.

; Note: this implementation, as written, betrays the author's
; CommonLisp-oriented style rather that a Schemish style (property lists
; rather than encapsulations).  Also, it allows entries with duplicate keys
; on the KEYS-AND-VALUES property list, which is inefficient, but otherwise
; causes no harm.

; Some examples of using this system follow:
;
; To assert that all insects are arthropods: 
;    (define-class 'arthropod 'insect)
; 
; To assert that all arthropods are invertebrates:
;    (define-class 'invertebrate 'arthropod)
;
; To assert that all arachnids are arthropods:
;    (define-class 'arthropod 'arachnid)
;
; To assert that all insects have six legs:
;    (define-class-default 'insect 'num-legs 'six)
;
; To assert that all arthropods have jointed legs:
;    (define-class-default 'arthropod 'leg-type 'jointed)
;
; To assert that all bees are insects:
;    (define-class 'insect 'bee) 
;
; To assert the details of bees coloring:
;    (define-class-default 'bee 'color 'striped)
;
; To assert that Eric is a bee:
;    (define-instance 'eric 'bee)
;
; To assert that Buzzy is a bee:
;    (define-instance 'buzzy 'bee)
;
; To assert that Eric has lost some legs:
;    (assert-property 'eric 'num-legs 'three)
;
; After these assertions, we could represent the knowledge in the system
; as a tree-diagram with "a-kind-of" (ako) links joining a subclass to its 
; superclass above, and "is-a" (isa) links joining an instance to the class 
; it is a member of. And using :: to denote default key values:
;
;    invertebrate
;      |       
;     (ako)
;      |      
;    arthropod
;    ::leg-type=jointed
;     |         |
;    (ako)    (ako)
;     |         |
;  arachnid    insect 
;              ::num-legs=six
;                   |
;                 (ako)
;                   |
;                  bee
;                  ::color=striped
;                  |          |
;                 (isa)      (isa)
;                  |          |
;                  buzzy      eric
;                             ::num-legs=three
; 
; To find whether Buzzy is a bee:
;    (class-member? 'buzzy 'bee)
;
; To find what class Eric is:
;    (get-class 'eric)
; 
; To find how many legs Buzzy has:
;    (get-property 'buzzy 'num-legs)
;
; To find whether bees are invertebrates:
;    (subclass? 'bee 'invertebrate)
; 
; Note that the answers to the last two examples illustrate inheritance,
; because the relevant values are specified as class-defaults and are 
; inherited by all subclasses that do not explicitly over-ride the defaults

    
;;; This global variable holds all the data for the frames system
(define *global-names* '())


(define (define-class superclass subclass)
  (let ((alist (assv subclass *global-names*)))
    (if alist
	(let ((sc (assv 'superclass (cdr alist))))
	  (if sc (set-cdr! sc superclass)
	      (set-cdr! alist (list (append (cadr alist) 
				      (list (list 'superclass superclass)))))))
	(set! *global-names* 
	      (append *global-names* 
		      (list (list subclass 
				  (list (list 'superclass superclass)))))))))


(define (define-instance instance class)
  (let ((alist (assv instance *global-names*)))
    (if alist
	(let ((sc (assv 'class (cdr alist))))
	  (if sc (set-cdr! sc class)
	      (set-cdr! alist (list (append (cadr alist) 
				      (list (list 'class class)))))))
	(set! *global-names* 
	      (append *global-names* 
		      (list (list instance
				  (list (list 'class class)))))))))


(define (define-class-default class key value)
  (assert-property class key value))


(define (get-keys-and-values object)
  (let ((alist (assv object *global-names*)))
    (if alist
	(let ((sc (assv 'keys-and-values (cadr alist))))
	  (if sc (cadr sc) #f))
	#f)))


(define (put-keys-and-values object keys-and-values)
  (let ((alist (assv object *global-names*)))
    (if alist
	;; changed:	(let ((sc (assv 'keys-and-values (cdr alist))))
	(let ((sc (assv 'keys-and-values (cadr alist))))
	  ;; changed:       (if sc (set-cdr! sc keys-and-values)
	  (if sc (set-cdr! sc (list keys-and-values))
	      (set-cdr! alist (list (append (cadr alist)
				      (list (list 'keys-and-values 
						  keys-and-values)))))))
	(set! *global-names* 
	      (append *global-names* 
		      (list (list object
				  (list (list 'keys-and-values 
					      keys-and-values)))))))))


(define (get-superclass subclass)
  (let ((alist (assv subclass *global-names*)))
    (if alist
	(let ((sc (assv 'superclass (cadr alist))))
	  (if sc (cadr sc) #f))
	#f)))


(define (get-class instance)
  (let ((alist (assv instance *global-names*)))
    (if alist
	(let ((sc (assv 'class (cadr alist))))
	  (if sc (cadr sc) #f))
	#f)))


(define (get-property instance property)
  (or (search-instance-for-property instance property)
      (search-classes-for-property (get-class instance) property)))


(define (search-instance-for-property instance property)
  (let ((pair (assoc property (get-keys-and-values instance))))
    (if pair
	(cadr pair)
      #f)))


(define (search-classes-for-property class property)
  (let ((pair (assoc property (get-keys-and-values class))))
    (if pair
	(cadr pair)
      (let ((superclass (get-superclass class)))
	(if superclass
	    (search-classes-for-property superclass property)
	  #f)))))


(define (subclass? sub super)
  (if (eqv? sub super)
      #t
      (let ((subsuper (get-superclass sub)))
        (if subsuper (subclass? subsuper super) #f))))


(define (class-member? instance class)
  (let ((instance-class (get-class instance)))
    (if instance-class (subclass? instance-class class) #f)))


(define (assert-property instance property value)
  (put-keys-and-values instance 
		       (cons (list property value) 
			     (get-keys-and-values instance))))