The less-familiar parts of Lisp for beginners — define-method-combination

As we continue on this tour of less commonly used functions, we reach define-method-combination.  This is really very rarely used.  There’s almost always another way to achieve the ends that this macro provides.  Peter Seibel, in his book Practical Common Lisp, remarks that this macro is necessary in maybe 1% of 1% of cases.

What this macro allows the programmer to do is to define new method combination rules.  There are the standard rules, which I described earlier in call-next-method.  There are several combination rules that run all applicable primary methods and apply an operation to them, from the set +,and, or, list, append, nconc, min, max, and progn.  When none of these is suitable, define-method-combination is available.

So, let’s set up an example.  In this scenario, we’ve got a tax policy simulator running.  There are three categories of tax rule sets, for students, adults, and retired people.  Not all rule sets contain methods for all tax regulations.  So, we declare that, when computing a tax regulation for a student, we use the student rule, unless there is no student rule for that regulation, in which case we use the adult rule.  If there is no adult rule, we use the retired rule.  Similarly, computing on an adult first tries adult rules, then student rules, then finally retired rules.  Given this model, we created a class system of multiple inheritance as follows:
 

(defparameter *student-tax-rate* 0.05)
(defparameter *adult-tax-rate* 0.20)
(defparameter *retired-tax-rate* 0.10)

(defparameter *student-pension-rate* 0.00)
(defparameter *adult-pension-rate* 0.10)
(defparameter *retired-pension-rate* 0.00)

(defclass student-tax-rules ()
  ())

(defclass adult-tax-rules ()
  ())

(defclass retired-tax-rules ()
  ())

(defclass student-taxpayer (student-tax-rules adult-tax-rules retired-tax-rules)
  ((special-income-rules        :initform nil)
   (special-pension-rules       :initform nil)))

(defclass adult-taxpayer (adult-tax-rules student-tax-rules retired-tax-rules)
  ((special-income-rules        :initform nil)
   (special-pension-rules       :initform nil)))

(defclass retired-taxpayer (retired-tax-rules adult-tax-rules student-tax-rules)
  ((special-income-rules        :initform nil)
   (special-pension-rules       :initform nil)))

(defgeneric compute-income-tax (ruleset income)
  (:documentation "Compute tax on income."))

(defgeneric compute-pension-payments (ruleset income)
  (:documentation "Compute pension contributions."))

(defmethod compute-income-tax ((rules student-tax-rules) income)
  (/ (floor (* income *student-tax-rate* 100.0d0)) 100))

(defmethod compute-income-tax ((rules adult-tax-rules) income)
  (/ (floor (* income *adult-tax-rate* 100.0d0)) 100))

(defmethod compute-income-tax ((rules retired-tax-rules) income)
  (/ (floor (* income *retired-tax-rate* 100.0d0)) 100))

(defmethod compute-pension-payments ((rules student-tax-rules) income)
  (/ (floor (* income *student-pension-rate* 100.0d0)) 100))

(defmethod compute-pension-payments ((rules adult-tax-rules) income)
  (/ (floor (* income *adult-pension-rate* 100.0d0)) 100))

(defmethod compute-pension-payments ((rules retired-tax-rules) income)
  (/ (floor (* income *retired-pension-rate* 100.0d0)) 100))

(defun demonstrate ()
  (let ((obj-student (make-instance 'student-taxpayer))
        (obj-adult (make-instance 'adult-taxpayer))
        (obj-retired (make-instance 'retired-taxpayer)))

    (let ((student-income 15000.0d0))
      (format t "Student earns $~,2F at a summer job~%" student-income)
      (format t "~8TPays $~,2F in income tax~%"
              (compute-income-tax obj-student student-income))
      (format t "~8TPays $~,2F in pension contributions~%"
              (compute-pension-payments obj-student student-income)))

    (let ((adult-income 35000.0d0))
      (format t "Adult earns $~,2F at job~%" adult-income)
      (format t "~8TPays $~,2F in income tax~%"
              (compute-income-tax obj-adult adult-income))
      (format t "~8TPays $~,2F in pension contributions~%"
              (compute-pension-payments obj-adult adult-income)))

    (let ((retired-income 5000.0d0))
      (format t "Retiree earns $~,2F babysitting~%" retired-income)
      (format t "~8TPays $~,2F in income tax~%"
              (compute-income-tax obj-retired retired-income))
      (format t "~8TPays $~,2F in pension contributions~%"
              (compute-pension-payments obj-retired retired-income)))))

This produces an output like this:
 

CL-USER> (demonstrate)
Student earns $15000.00 at a summer job
        Pays $750.00 in income tax
        Pays $1275.00 in pension contributions
Adult earns $35000.00 at job
        Pays $7000.00 in income tax
        Pays $2975.00 in pension contributions
Retiree earns $5000.00 babysitting
        Pays $500.00 in income tax
        Pays $425.00 in pension contributions
NIL

I’ve made very simple tax rules, in a real simulator, things would be more complicated, and would likely be a function of work history, marital status, and so on, so changing two sets of rules to look similar would not be a simple matter of changing a single scalar parameter.

So, your simulator is running, you’re getting requests from politicians to simulate certain changes to the rules, and a new one comes in that doesn’t fit your data model.  The proposed change is to reduce the pension contributions in adults and shift them to students and retired people.  It is to be done by saying that the pension contribution for any person is 85% of the maximum pension contribution under any of the three sets of rules.  Where before a given taxpayer invoked only one method when asked to compute pension contributions, now we must compute all available rules, find the largest, and return 85% of that number.  We do this by defining a new method combination rule and declaring that pension contribution methods must use it.  I’m modifying the template in the CLHS page on define-method-combination, one that implements the standard method combination rules:
 

(define-method-combination pension-contrib-combination ()
  ((around (:around))
   (before (:before))
   (primary () :required t)
   (after (:after)))
  (flet ((call-methods (methods)
           (mapcar #'(lambda (method)
                       `(call-method ,method))
                   methods)))
    (let ((form (if (or before after (rest primary))
                    `(multiple-value-prog1
                         (progn ,@(call-methods before)
                                (* 0.85 
                                   (funcall 'max 
                                            ,@(call-methods primary))))
                       ,@(call-methods (reverse after)))
                    `(call-method ,(first primary)))))
      (if around
          `(call-method ,(first around)
                        (,@(rest around)
                           (make-method ,form)))
          form))))

(defgeneric compute-pension-payments (ruleset income)
  (:method-combination pension-contrib-combination)
  (:documentation "Compute pension contributions."))

Now, when we run the test function, we get this output:
 

CL-USER> (demonstrate)
Student earns $15000.00 at a summer job
        Pays $750.00 in income tax
        Pays $1275.00 in pension contributions
Adult earns $35000.00 at job
        Pays $7000.00 in income tax
        Pays $2975.00 in pension contributions
Retiree earns $5000.00 babysitting
        Pays $500.00 in income tax
        Pays $425.00 in pension contributions
NIL

Now, you can run your simulation, present the results, and then return to the usual mode of running.  One warning: at least under SBCL v1.14, simply removing the :method-combination option from the defgeneric will not return the method combination rules to their standard behaviour in a running Lisp instance.  To reset the behaviour without reloading the Lisp image, you should load a new defgeneric with the :method-combination option set to standard.

Leave a Reply

Your email address will not be published. Required fields are marked *

You may use these HTML tags and attributes: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

*

反垃圾邮件 / Anti-spam question * Time limit is exhausted. Please reload CAPTCHA.