;; -*- scheme -*-
;; functional object model, adapted from
;; http://okmij.org/ftp/Scheme/pure-oo-system.scm


;; functional substitution in an assoc list
(define (new-mmap mmap tag new-body)
  (cond
   ((null? mmap) '())    ;; end of list

   ((eq? tag (caar mmap))	
    ;; if tag matches, replace entry
    (cons 
     (cons tag new-body) ;; new entry
     (cdr mmap)))        ;; rest
   (else 
    ;; if not, recurse down list
    (cons 
     (car mmap) 
     (new-mmap 
      (cdr mmap) tag new-body)))))

;; make dispatcher closure (object)
(define (make-dispatcher message-map)

  ;; the dispatcher closure
  (define (dispatcher selector . args)
    (cond

     ;; get closure data (message map)
     ((eq?  selector 'mmap) message-map)

     ;; lookup method in message map
     ((assq selector message-map) =>
      (lambda (member)
	(apply (cdr member) (cons dispatcher args))))

     ;; default my-class message
     ((eq? selector 'my-class) (list dispatcher "UNKNOWN"))

     ;; unknown message
     (else (error 
	    (dispatcher 'my-class) 
	    " does not understand " selector))))

  dispatcher)


;; functional get/set

(define (make-getter value) 
  (lambda (self) (list self value)))

(define (make-setter get-tag)
  (lambda (self value)
    (list
     (make-dispatcher
      (new-mmap (self 'mmap)
		get-tag
		(make-getter value))))))

;; test
(define (make-thing x)
  (define message-map
    `((get . ,(make-getter x))
      (set . ,(make-setter 'get)))) ;; a setter modifies a getter

  (make-dispatcher message-map))


;; inheritance
(define (make-thang x)
  (make-dispatcher 
   (append `((print . ,(lambda (self) 
			 (display (cadr (self 'get))) 
			 (newline) 
			 (list self))))
	 ((make-thing x) 'mmap))))