《实用Common Lisp编程》第三章，update 函数补遗

细心的人应该会发现，在第三章的最后，作者只将where函数改成了宏，而update函数仍然是带有重复代码：

(defun update (selector-fn &key title artist rating (ripped nil ripped-p))
    (setf *db*
        (mapcar
            #'(lambda (row)
                (when (funcall selector-fn row)
                    (if title                                               
                        (setf (getf row :title) title))
                    (if artist
                        (setf (getf row :artist) artist))
                    (if rating
                        (setf (getf row :rating) rating))
                    (if ripped-p
                        (setf (getf row :ripped) ripped)))
                row)
            *db*)))

 

重复代码集中在不必要的判断当中，作为课后练习，我们这就来解决它。

首先，我们要写一个函数，它接受两个参数 field 和 value，作为宏的辅助函数，用于修改 cd 数据，这一函数和书中的 make-comparsion-expr 很相似，因此我称之为 make-update-expr：

(defun make-update-expr (field value)
    `(setf (getf row ,field) ,value))

 

嗯，看上去不错，在REPL中试试：

[2]> (make-update-expr :title "hello")

(SETF (GETF ROW :TITLE) "hello")

测试成功！接下来，我们还需要一个像where函数的辅助函数 make-comparisons-list 那样，从一个列表中提取多个 field-value 对并将参数传给 make-update-expr 的函数，我称之为 make-updates-list ：

(defun make-updates-list (fields)
    (loop while fields
        collecting (make-update-expr (pop fields) (pop fields))))

上面的函数遍历 fields 列表，从中提取 field-value 对，并生成宏所需的表达式。

再在REPL中试试它：

[4]> (make-updates-list *test-field-value-list*)

((SETF (GETF ROW :TITLE) "hello") 

 (SETF (GETF ROW :ARTIST) "huangz"))

一切顺利，是时候让新的 update 函数登场了：

(defmacro update (selector-fn &rest clauses)
    `(setf *db*
        (mapcar
            #'(lambda (row)
                (when (funcall ,selector-fn row)
                    ,@(make-updates-list clauses))
                row)
            *db*)))

 

新的 update 函数和它的哥哥很相似，主要区别在于参数部分，将原本的 title、artist 之类的替换成了 &rest clauses ，可以接受不定数目的参数。

另外，在函数的中间，我们将原本重复的代码换成了 ,@(make-updates-list clauses) ，这行代码在宏执行的时候就会被展开，生成我们需要的代码，不多也不少。

最后，现在这个无论 cd 的数据域怎么变，这个update都不用修改，因为它足够通用，这就是新版的 update 对比旧版 update 的另一个显著的好处。

再次拜访我们的老朋友REPL，先展开宏看看：

[5]> (macroexpand-1 '(update (where :artist "huangz") :rating 10 :ripped t))

(SETF *DB*

 (MAPCAR

  #'(LAMBDA (ROW)

     (WHEN (FUNCALL (WHERE :ARTIST "huangz") ROW) 

         (SETF (GETF ROW :RATING) 10)

         (SETF (GETF ROW :RIPPED) T))

     ROW)

  *DB*)) ;

核心部分是两个 SETF 语句，它们是通过宏生成的，嗯，看上去如我们意料一样，现在，用数据测试下：

[11]> (dump-db)

TITLE:    world

ARTIST:   huangz

RATING:   8

RIPPED:   T

TITLE:    hello

ARTIST:   huangz

RATING:   3

RIPPED:   NIL

NIL

[12]> (update (where :artist "huangz") :rating 10 :ripped t)

((:TITLE "world" :ARTIST "huangz" :RATING 10 :RIPPED T) (:TITLE "hello" :ARTIST "huangz" :RATING 10 :RIPPED T))

[13]> (dump-db)

TITLE:    world

ARTIST:   huangz

RATING:   10

RIPPED:   T

TITLE:    hello

ARTIST:   huangz

RATING:   10

RIPPED:   T

NIL

测试成功，我们更新了两张 artist 为 "huangz" 的唱片的 rating、ripped 数据域。

嗯。。。看上去这道课后练习还暂时未能结束，因为在新的 update 函数和新的 where 的辅助函数中，我们看到了新的重复代码：

; where helper
(defun make-comparison-expr (field value)
    `(equal (getf cd ,field) ,value))

(defun make-comparisons-list (fields)
    (loop while fields
        collecting (make-comparison-expr (pop fields) (pop fields))))

; update helper
(defun make-update-expr (field value)
    `(setf (getf row ,field) ,value))

(defun make-updates-list (fields)
    (loop while fields
        collecting (make-update-expr (pop fields) (pop fields))))

哈，问题就在这，让我们继续消灭重复，将抽象(脑抽筋)进行到底。

很明显， make-comparison-expr 和 make-update-expr 只有一个函数（equal和setf）之差，我们可以抽象出一个 make-some-expr 函数或宏，但是，慢着，因为它们都是辅助函数，所以在它们的体内，有各自的自由变量，分别是 row 和 cd，这样一来，虽然我们可以继续对它们两进行抽象，但是，我想，这意义不大，说不定将来的麻烦会比好处多。

因此，我决定将目标移向 make-comparisons-list 和 make-updates-list ，这两个函数体内没有自由变量，而且区别只在于一个函数之差，我们两三下功夫就能抽象出一个新的通用函数：

(defun make-func-lists (func fields)
    (loop while fields
        collecting (funcall func (pop fields) (pop fields))))

测试一下，你就知道：

; 测试 make-update-expr

[5]> (defvar *test-list-1* (list :artist "huangz" :rating 5))

*TEST-LIST-1*

[11]> (make-func-lists #'make-update-expr *test-list-1*)

((SETF (GETF ROW :ARTIST) "huangz") (SETF (GETF ROW :RATING) 5))

; 测试 make-comparison-expr

[12]> (defvar *test-list-2* (list :title "hello" :ripped t))

*TEST-LIST-2*

[13]> (make-func-lists #'make-comparison-expr *test-list-2*)

((EQUAL (GETF CD :TITLE) "hello") (EQUAL (GETF CD :RIPPED) T))

嗯，以下就是我们新的 make-comparisons-list 和 make-updates-list 函数了：

(defun make-updates-list (fields)
    (make-func-lists #'make-update-expr fields))

(defun make-comparisons-list (fields)
    (make-func-lists #'make-comparison-expr fields))

 

在实际数据中测试一下子：

[3]> (dump-db)

TITLE:    world

ARTIST:   huangz

RATING:   8

RIPPED:   T

TITLE:    hello

ARTIST:   huangz

RATING:   3

RIPPED:   NIL

NIL

[4]> (where :rating 8)

#<FUNCTION :LAMBDA (CD) (AND (EQUAL (GETF CD :RATING) 8))>

[5]> (where :title "hello" :rating 8)

#<FUNCTION :LAMBDA (CD) (AND (EQUAL (GETF CD :TITLE) "hello") (EQUAL (GETF CD :RATING) 8))>

[6]> (select (where :rating 3 :artist "huangz"))

((:TITLE "hello" :ARTIST "huangz" :RATING 3 :RIPPED NIL))

[7]> (update (where :rating 3 :artist "huangz") :title "He!!0" :rating 5)

((:TITLE "world" :ARTIST "huangz" :RATING 8 :RIPPED T) (:TITLE "He!!0" :ARTIST "huangz" :RATING 5 :RIPPED NIL))

[8]> (dump-db)

TITLE:    world

ARTIST:   huangz

RATING:   8

RIPPED:   T

TITLE:    He!!0

ARTIST:   huangz

RATING:   5

RIPPED:   NIL

NIL

嗯，我们先是用宏改写了 update 函数，然后通过新的函数 make-func-lists，将 make-updates-list 和 make-comparisons-list 函数改头换面。

我们的数据库程序在减少重复代码方面又达到了一个新的高度，抽象层次直逼外太空，我几乎快要缺氧了。阿阿阿。。。

----------

;;;; 新代码片段，其余代码和书中的一样

;;; 

(defun make-func-lists (func fields)
    (loop while fields
        collecting (funcall func (pop fields) (pop fields))))

;;; where function

(defun make-comparison-expr (field value)
    `(equal (getf cd ,field) ,value))

(defun make-comparisons-list (fields)
    (make-func-lists #'make-comparison-expr fields))

(defmacro where (&rest clauses)
    `#'(lambda (cd)
        (and
            ,@(make-comparisons-list clauses))))

;;; update function

(defun make-update-expr (field value)
    `(setf (getf row ,field) ,value))

(defun make-updates-list (fields)
    (make-func-lists #'make-update-expr fields))

(defmacro update (selector-fn &rest clauses)
    `(setf *db*
        (mapcar
            #'(lambda (row)
                (when (funcall ,selector-fn row)
                    ,@(make-updates-list clauses))
                row)
            *db*)))