;;; -*- mode: lisp; syntax: common-lisp -*-
;;;
;;; ソース変換を用いたOOP拡張
;;; Peter Salvi, 2009.05.18.

;;; 以下のプログラムは至って簡単な物で、玩具に過ぎません。
;;; 欠けているのは:
;;; - 多重継承
;;; - エラー対応
;;; - カプセル化
;;; - 多数の変数によるダイナミック呼び出し
;;; - 他にも色々

(in-package :cl-user)
(defpackage :oo-compiler
  (:nicknames :oo)
  (:use :common-lisp)
  (:export :クラス :コンストラクタ :メソッド :インスタンス :祖先 :この :これ :値))
(in-package :oo-compiler)

;;; 使い方:
;;
;; (クラス <名前> <祖先>
;;   (:クラス変数 ...)
;;   (:インスタンス変数 ...)
;;   (:メソッド ...))
;;
;; (コンストラクタ <クラス> (<引数...>)
;;   <実装...>)
;;
;; (メソッド <クラス> <名前> (<引数...>)
;;   <実装...>)
;;
;; 新しいインスタンスの作り方: (インスタンス <引数...>)
;;
;; メソッド内の変数の値: (この <変数>)
;; メソッド外の変数の値: (値 <インスタンス/クラス> <変数>)
;; メソッド内で祖先のメソッドを呼び出す: (祖先 <メソッド名> <引数...>)
;;   <メソッド名> が :コンストラクタ も可

(defvar *classes* (make-hash-table))

;;; Classes
;;; -------
;;; A class is a list: (parent names constructor methods class-vars)
;;;   where parent is the parent class's name or NIL
;;;         names is a list: ((:インスタンス変数 ...) (:クラス変数 ...))
;;;         constructor is a function
;;;         methods is a hash map of functions (key: method name)
;;;         class-vars is a hash map of values (key: class variable name)
;;; To handle these data, the following convenience functions are defined:
(defun parent (class) (first (gethash class *classes*)))
(defun assoc-names (alist type) (cdr (assoc type alist)))
(defun class-names (class type)
  (assoc-names (second (gethash class *classes*)) type))
(defun instance-vars (class) (class-names class :インスタンス変数))
(defun class-vars (class) (class-names class :クラス変数))
(defun constructor (class) (third (gethash class *classes*)))
(defun (setf constructor) (value class)
  (setf (third (gethash class *classes*)) value))
(defun cmethod (class name)
  (gethash name (fourth (gethash class *classes*))))
(defun (setf cmethod) (value class name)
  (setf (gethash name (fourth (gethash class *classes*))) value))
(defun class-var (class name)
  (gethash name (fifth (gethash class *classes*))))
(defun (setf class-var) (value class name)
  (setf (gethash name (fifth (gethash class *classes*))) value))

;;; Class-defining macro
;;; Puts all the given class data in the *CLASSES* variable, including those
;;; inherited from the parent class, and defines functions for the methods.
(defmacro クラス (name parent &rest properties)
  `(progn
     (setf (gethash ',name *classes*)
           (list ',parent
                 (list
                  (cons :インスタンス変数
                        (append (class-names ',parent :インスタンス変数)
                                ',(assoc-names properties :インスタンス変数)))
                  (cons :クラス変数
                        (append (class-names ',parent :クラス変数)
                                ',(assoc-names properties :クラス変数))))
                   nil (make-hash-table) (make-hash-table)))
     ,@(loop for method in (rest (find :メソッド properties :key #'first))
          for instance = (gensym) and args = (gensym) collect
            `(defun ,method (,instance &rest ,args)
               (apply (search-method (instance-class ,instance) ',method)
                      ,instance ,args)))))

;;; Instances
;;; An instance is a list: (class data)
;;;   where class is the name of the instance's class
;;;   data is a hash map of values (key: instance variable name)
;;; To handle these data, the following convenience functions are defined:
(defun instance-class (instance) (first instance))
(defun instance-var (instance name) (gethash name (second instance)))
(defun (setf instance-var) (value instance name)
  (setf (gethash name (second instance)) value))

;;; Variable evaluation
(defun evaluate-var (instance-or-class name)
  (cond ((atom instance-or-class)
         (cond ((null (gethash instance-or-class *classes*))
                (error "No such class: ~a" instance-or-class))
               ((member name (class-vars instance-or-class))
                (class-var instance-or-class name))
               (t (error "Cannot find class variable ~a" name))))
        ((member name (class-vars (instance-class instance-or-class)))
         (class-var (instance-class instance-or-class) name))
        ((member name (instance-vars (instance-class instance-or-class)))
         (instance-var instance-or-class name))
        (t (error "Cannot find the variable ~a" name))))
(defun (setf evaluate-var) (value instance-or-class name)
  (cond ((atom instance-or-class)
         (cond ((null (gethash instance-or-class *classes*))
                (error "No such class: ~a" instance-or-class))
               ((member name (class-vars instance-or-class))
                (setf (class-var instance-or-class name) value))
               (t (error "Cannot find class variable ~a" name))))
        ((member name (class-vars (instance-class instance-or-class)))
         (setf (class-var (instance-class instance-or-class) name) value))
        ((member name (instance-vars (instance-class instance-or-class)))
         (setf (instance-var instance-or-class name) value))
        (t (error "Cannot find the variable ~a" name))))
(defmacro 値 (instance-or-class name)
  `(evaluate-var ,instance-or-class ',name))

;;; Methods
(defun call-parent (instance name &rest args)
  (if (eq name :コンストラクタ)
      (apply (constructor (parent (instance-class instance)))
             instance args)
      (apply (cmethod (parent (instance-class instance)) name)
             instance args)))

;;; Instead of using environments, we capture some symbols
(defun interpret-sexp (instance sexp)
  (cond ((atom sexp) (if (eq sexp 'これ) instance sexp))
        ((eq (first sexp) 'この) `(evaluate-var ,instance ',(second sexp)))
        ((eq (first sexp) '祖先)
         `(call-parent ,instance ,(second sexp) ,@(subseq sexp 2)))
        (t (cons (interpret-sexp instance (first sexp))
                 (interpret-sexp instance (rest sexp))))))

(defmacro コンストラクタ (class args &body body)
  (let ((instance (gensym)))
    `(setf (constructor ',class)
           (lambda (,instance ,@args)        
             ,@(mapcar (lambda (sexp) (interpret-sexp instance sexp))
                       body)
             ,instance))))

(defun search-method (class name)
  (if class
      (or (cmethod class name)
          (let ((parent (parent class)))
            (and parent (search-method parent name))))
      (error "Cannot find the method ~a" name)))

(defmacro メソッド (class name args &body body)
  (let ((instance (gensym)))
    `(setf (cmethod ',class ',name)
           (lambda (,instance ,@args)
             ,@(mapcar (lambda (sexp) (interpret-sexp instance sexp))
                       body)))))

;;; Object creation
(defmacro インスタンス (class &rest args)
  `(funcall (constructor ',class)
            (list ',class (make-hash-table))
            ,@args))

;;; 例:
#+nil (progn ; start of comment region




(クラス 形状 nil
  (:クラス変数 頂点の数)
  (:インスタンス変数 色)
  (:メソッド 面積 周囲 合計))

(クラス 三角形 形状
  (:インスタンス変数 a b c))

(クラス 正方形 形状
  (:インスタンス変数 a))

(コンストラクタ 形状 (色)
  (setf (この 色) 色))

(コンストラクタ 三角形 (a b c 色)
  (祖先 :コンストラクタ 色)
  (setf (この 頂点の数) 3
        (この a) a
        (この b) b
        (この c) c))

(コンストラクタ 正方形 (a 色)
  (祖先 :コンストラクタ 色)
  (setf (この 頂点の数) 4
        (この a) a))

(メソッド 形状 合計 (n)
  (+ (面積 これ) (周囲 これ) n))

(メソッド 三角形 周囲 ()
  (+ (この a) (この b) (この c)))

(メソッド 三角形 面積 ()
  (let ((半周囲 (/ (周囲 これ) 2)))
    (sqrt (* 半周囲
             (- 半周囲 (この a))
             (- 半周囲 (この b))
             (- 半周囲 (この c))))))

(メソッド 正方形 周囲 ()
  (* (この a) 4))

(メソッド 正方形 面積 ()
  (expt (この a) 2))

(let ((形1 (インスタンス 三角形 3 4 5 '赤))
      (形2 (インスタンス 正方形 4 '緑)))
  (print (周囲 形1))                    ; 12
  (print (周囲 形2))                    ; 16
  (print (面積 形1))                    ; 6.0
  (print (面積 形2))                    ; 16
  (print (値 形1 頂点の数))             ; 3
  (print (値 形2 色))                   ; 緑
  (print (合計 形1 15)))                ; 33.0

) ; end of comment region