(require (lib "defmacro.ss"))
(require (lib "match.ss"))
(require (lib "etc.ss"))
(require (lib "string.ss"))

(define y
  (λ (x)
    ((λ (p) (x (λ n (apply (p p) n))))
     (λ (p) (x (λ n (apply (p p) n)))))))

(define-macro y-λ
  (λ (params . body)
    (let ((self-symbol (car params))
          (rest-params (cdr params)))
      `(y (λ (,self-symbol) (λ ,rest-params ,@body))))))

(define-macro ->
  (λ (object key . params)
    (let ((value (gensym)))
      `(let ((,value (,object ',key)))
         (if (procedure? ,value)
             (apply ,value (cons ,object (list ,@params)))
             ,value)))))

(define-macro :=
  (λ (object key value)
    `(apply (,object 'set-slot) (list ,object ',key ,value))))

(define-macro method
  (λ (params . body)
    `(λ ,@(list (cons 'self params)) ,@body)))

(define object
  (let ((table (make-hash-table)))
    (map (λ (pair) (hash-table-put! table (car pair) (cadr pair)))
         `(
           (clone
            ,(method ()
               (let ((result (make-object self)))
                 (-> result initialize)
                 result)))
           (get-slot
            ,(method (key)
              (hash-table-get (self) key)))
           (set-slot
            ,(method (key value)
              (hash-table-put! (self) key value)
              self))
             ))
    (y-λ (self key) (hash-table-get table key '()))))

(define make-object
  (lambda (&optional (parent object))
    (let ((table (make-hash-table)))
      (hash-table-put! table 'protos (list parent))
      (y (λ (self) (lambda (&optional key)
                     (if (not key)
                         table
                         (let ((value (hash-table-get table key '())))
                           (if (null? value)
                               (unless (eq? 'protos key)
                                 (let proto-lookup ((protos (-> self protos)))
                                   (if (null? protos)
                                       '()
                                       (let* ((proto (car protos))
                                              (value (proto key)))
                                         (if (null? value)
                                             (proto-lookup (cdr protos))
                                             value)))))
                               value)))))))))

(define person (-> object clone))
(:= person with
    (method (name)
      (let ((result (-> self clone)))
        (:= result name name))))
(:= person greet
    (method ()
      (display "Hi, my name is ")
      (display (self 'name))
      (display ".")(newline)))

(define student (-> person clone))
(:= student initialize
    (λ (self)
      (:= self studies '())))
(:= student study
    (λ (self . subjects)
      (:= self studies (append subjects (-> self studies)))))
(:= student greet 
    (method ()
      ((person 'greet) self)
      (display "I study: ")
      (let ((studies (reverse (-> self studies))))
        (map (λ (subject) (display subject) (display ", ")) (cdr studies))
        (if (> (length studies) 1)
            (display "and "))
        (display (car studies)))
      (display ".")(newline)))

(define bob (-> person with "Bob"))
(-> bob greet) ; Hi, my name is Bob.

(define fred (-> student with "Fred"))
(-> fred study "Calculus" "French" "Music")
(-> fred greet) ; Hi my name is Fred. I study: Calculus, French, and Music.