'T

メソッドコンビネーションでFizzBuzz (2)

CLOS | 23:19

前回、メソッド修飾子を数値で表現して、それでFizzBuzzできるんじゃないかと考えてみましたが、CLtL2のdefine-method-combinationの説明用のコードが元ネタになります。

内容としては、まず、メソッド修飾子をmethod-qualifiersで集めて、修飾子が数値なので順番にソートしたものが優先順位として並べられるというものみたいです。

修飾子は、

(method-qualifiers (find-method #'fizzbuzz '(1) (list (find-class 'one))))

みたいにして取得できます。

それで、前回と比べてあまりかわりばえしないのですが、

(defclass one () ())
(defmethod fizzbuzz 1 ((obj one))
  (format t "~A~%" 1))

(defclass two (one) ())
(defmethod fizzbuzz 2 ((obj two))
  (format t "~A~%" 2))

みたいな定義を作って行くことになります。

しかし、クラスと修飾子の意味が被ってるので、ぱっとしないのがくやしい。

ちなみに、修飾子で順番を決めているので、:most-specific-firstであろうが、:most-specific-lastを指定しようが、1から順番に実行されます。

;;;
;;; 動作
;;;

;; 総称関数定義
(defgeneric fizzbuzz (cls)
  (:method-combination fizzbuzz))

(loop :for i :from 1 :to 100 :do (make-fizzbuzz#2 i))

;; 実行
(fizzbuzz (make-instance '|ONE HUNDRED|))

...
82
83
Fizz
Buzz
86
Fizz
88
89
Fizz Buzz
91
92
Fizz
94
Buzz
Fizz
97
98
Fizz
Buzz

;; メソッドコンビネーションの定義 CLtL2参照(というかそのまま)
(define-method-combination fizzbuzz () 
        ((methods positive-integer-qualifier-p)) 
  `(progn ,@(mapcar #'(lambda (method) 
                        `(call-method ,method ())) 
                    (stable-sort methods #'< 
                      :key #'(lambda (method) 
                               (first (method-qualifiers 
                                        method))))))) 

(defun positive-integer-qualifier-p (method-qualifiers) 
  (and (= (length method-qualifiers) 1) 
       (typep (first method-qualifiers) '(integer 0 *)))) 

;; 型で振り分けるので型を定義
(deftype fizz ()
  (let ((g (gensym)))
    (setf (symbol-function g) (lambda (x) (zerop (rem x 3))))
    `(satisfies ,g)))

(deftype buzz ()
  (let ((g (gensym)))
    (setf (symbol-function g) (lambda (x) (zerop (rem x 5))))
    `(satisfies ,g)))

(deftype fizzbuzz () '(and fizz buzz))

;; 99 -> NINETY-NINE みたいなものを作成する
(defun make-roman-number-symbol (n)
  (values (intern (format nil "~:@(~R~)" n))))

(defmacro make-fizzbuzz#2 (n)
  `(eval
    `(progn
       (defclass
             ,#1=(make-roman-number-symbol ,n) 
             ,(if (zerop (1- ,n)) () `(,(make-roman-number-symbol (1- ,n)))) 
             () )
       (defmethod fizzbuzz ,(eval ,n) ((cls ,#1#))
         (format T ,@(typecase ,n
                       (fizzbuzz (list "Fizz Buzz~%"))
                       (buzz (list "Buzz~%"))
                       (fizz (list "Fizz~%"))
                       (otherwise (list "~A~%" ,n))))))))

■