ANSI Common Lisp 学习笔记 第四章

* 第四章：特殊数据结构

** 4.1 数组(Array)

*** #'make-array

(setf arr (make-array '(2 3) :initial-element nil))

# Common Lisp 的数组至少可以有七个维度，每个维度至少可以有 1023 个元素。 :initial-element 实参是选择性的。如果有提供这个实参，整个数组会用这个值作为初始值。若试著取出未初始化的数组内的元素，其结果为未定义(undefined)。 如果我们只想要一维的数组，你可以给 make-array 第一个实参传一个整数，而不是一个列表：

(setf vec (make-array 4 :initial-elment nil))

#(NIL NIL NIL NIL)

*** #'aref 用 aref 取出数组内的元素。与 Common Lisp 的存取函数一样， aref 是零索引的(zero-indexed)：

(aref arr 0 0)

NIL

*** #'setf

(setf (aref arr 0 0) 'b)

B

(aref arr 0 0)

B

*** literal array 要表示字面常量的数组(literal array)，使用 #na 语法，其中 n 是数组的维度。举例来说，我们可以这样表示 arr 这个数组： #2a((b nil nil) (nil nil nil))

*** vertor

(vector "a" 'b 3)

#("a" b 3)

*** svref (svref vec 0) NIL 在 svref 内的 “sv” 代表“简单向量”(“simple vector”)，所有的向量缺省是简单向量。 [1] 一个简单数组大小是不可调整、元素也不可替换的，并不含有填充指针(fill-pointer)。数组缺省是简单的。简单向量是个一维的简单数组，可以含有任何类型的元素。

** Strings

*** #'char<

*** #'char<=

*** #'char=

*** #'char>=

*** #'char>

*** #'char/=

*** #'aref

*** #'char

(char "abc" 1)

#\b

(let ((str (copy-seq "Merlin")))
  (setf (char str 3) #\k)
  str)

*** #'string-equal

(equal "fred" "Fred")

NIL

(equal "fred" "fred")

T

(string-equal "fred" "Fred")

T

*** #'format 有许多方式可以创建字串。最普遍的方式是使用 format 。将第一个参数设为 nil 来调用 format ，使它返回一个原本会印出来的字串：

(format nil "~A or ~A" "truth" "dare")

"truth or dare"

*** #'concatenate

但若你只想把数个字串连结起来，你可以使用 concatenate ，它接受一个特定類型的符号，加上一个或多个序列：

(concatenate 'string "not " "to worry")

"not to worry"

** 4.4 序列 (Sequences)

*** remove, length, subseq, reverse, sort, every, some

在 Common Lisp 里，序列类型包含了列表与向量(因此也包含了字串)。有些用在列表的函数，实际上是序列函数，包括 remove 、 length 、 subseq 、 reverse 、 sort 、 every 以及 some

*** nth, aref, svref, char, elt 我们已经看过四种用来取出序列元素的函数： 给列表使用的 nth ， 给向量使用的 aref 及 svref ，以及给字串使用的 char 。 Common Lisp 也提供了通用的 elt ，对任何种类的序列都有效：

(elt '(a b c) 1)

B 频繁的对列表调用 elt 的代价是昂贵的，因为列表仅允许循序存取。而向量允许随机存取，从任何元素来存取每一个元素都是廉价的。

*** &key

许多序列函数接受一个或多个，由下表所列的标准关键字参数：
 

*** position

(position #\a "fantasia")

1

(position #\a "fantasia" :start 3 :end 5)

4

(position #\a "fantasia" :from-end t)

7

(position 'a '((c d) (a b)) :key #'car)

1

(position '(a b) '((a b) (c d)))

NIL

(position '(a b) '((a b) (c d)) :test #'equal)

0

(position 3 '(1 0 7 5) :test #'<)

2 使用 subseq 与 position ，我们可以写出分开序列的函数。举例来说，这个函数

(defun second-word (str)
  (let ((p1 (+ (position #\ str) 1)))
    (subseq str p1 (position #\ str :start p1))))

(second-word "Form follows function") "follows" *** #'position-if

(position-if #'oddp '(2 3 4 5))

1 position-if 接受除了 :test 之外的所有关键字参数。 许多相似的函数，如给序列使用的 member 与 member-if 。

*** #'find

(接受全部关键字参数)

*** #'find-if

(接受除了 :test 之外的所有关键字参数)

不同于 member 与 member-if ，它们仅返回要寻找的对象。 通常一个 find-if 的调用，如果解读为 find 搭配一个 :key 关键字参数的话，会显得更清楚。举例来说，表达式

(find-if #'(lambda (x)
             (eql (car x) 'complete))
         lst)

(find 'complete lst :key #'car)

*** remove-duplicates 仅保留序列中每个元素的最后一次出现。

(remove-duplicates "abracadabra")

"cdbra" 这个函数接受前表所列的所有关键字参数。

*** reduce n用来把序列压缩成一个值。它至少接受两个参数，一个函数与序列。函数必须是接受两个实参的函数。在最简单的情况下，一开始函数用序列前两个元素作为实参来调用，之后接续的元素作为下次调用的第二个实参，而上次返回的值作为下次调用的第一个实参。最后调用最终返回的值作为 reduce 整个函数的返回值。也就是说像是这样的表达式

(reduce #'fn '(a b c d))

等同于

(fn (fn (fn 'a 'b) 'c) 'd)

我们可以使用 reduce 来扩充只接受两个参数的函数。举例来说，要得到三个或多个列表的交集(intersection)，我们可以：

(reduce #'intersection '((b r a d 's) (bad) (cat)))

(A)

*** Time-stamp: <2013-04-26 Friday 13:10:26>

** 4.5 示例：解析日期 (Example: Parsing Dates)

(defun tokens (str test start)
  (let ((p1 (position-if test str :start start)))
    (if p1;找到第一个token
        (let ((p2 (position-if #'(lambda (c)
				   (not (funcall test c)))
			       str :start p1)))
	  ;;P2是下一个不通过test的字符
          (cons (subseq str p1 p2)
                (if p2
                    (tokens str test p2)
                    nil)))
        nil)))

;; (tokens "123abc4 58.54 5" #'digit-char-p 0)

(defun constituent (c)
  (and (graphic-char-p c)
       (not (char= c #\ ))))

(defun parse-date (str)
  (let ((toks (tokens str #'constituent 0)))
    (list (parse-integer (first toks))
          (parse-month (second toks))
          (parse-integer (third toks)))))

(defconstant month-names
  #("jan" "feb" "mar" "apr" "may" "jun"
    "jul" "aug" "sep" "oct" "nov" "dec"))

(defun parse-month (str)
  (let ((p (position str month-names
                         :test #'string-equal)))
    (if p
        (+ p 1)
        nil)))

(parse-date "80 MAr 19")

*** #'graphic-char-p

*** #'alpha-char-p

*** #'digit-char-p

** 4.6 结构 (Structures)

(defstruct point
  x
  y)

(setf p (make-point :x 0 :y 0))

;; #S(POINT :X 0 :Y 0)

(setf (point-y p) 2)

定义结构也定义了以结构为名的类型。每个点的类型层级会是，类型 point ，接著是类型 structure ，再来是类型 atom ，最后是 t 类型。所以使用 point-p 来测试某个东西是不是一个点时，也可以使用通用性的函数，像是 typep 来测试。 结构显示的方式也可以控制，以及结构自动产生的存取函数的字首。

(defstruct (point (:conc-name p)
                  (:print-function print-point))
  (x 0)
  (y 0))

(defun print-point (p stream depth)
  (format stream "#<~A, ~A>" (px p) (py p)))

:conc-name 关键字参数指定了要放在字段前面的名字，并用这个名字来生成存取函数。预设是 point- ；现在变成只有 p 。不使用缺省的方式使代码的可读性些微降低了，只有在需要常常用到这些存取函数时，你才会想取个短点的名字。 :print-function 是在需要显示结构出来看时，指定用来打印结构的函数 –– 需要显示的情况比如，要在顶层显示时。这个函数需要接受三个实参：要被印出的结构，在哪里被印出，第三个参数通常可以忽略。

** 4.7 示例：二叉搜索树 (Example: Binary Search Tree) ;; elt -- element, l -- left-child, r -- right-child

(defstruct (node (:print-function
                  (lambda (n s d)
                    (format s "#<~A>" (node-elt n)))))
  elt (l nil) (r nil))

(defun bst-insert (obj bst <)
  (if (null bst)
      (make-node :elt obj)
      (let ((elt (node-elt bst)))
        (if (eql obj elt);;if equal, return old bst
            bst
            (if (funcall < obj elt);; if smaller
                (make-node
                   :elt elt
                   :l (bst-insert obj (node-l bst) <);; insert to left-half
                   :r (node-r bst))
                (make-node
                   :elt elt
                   :r (bst-insert obj (node-r bst) <);; else insert to right-half
                   :l (node-l bst)))))))

(defun bst-find (obj bst <)
  (if (null bst)
      nil
      (let ((elt (node-elt bst)))
        (if (eql obj elt)
            bst
            (if (funcall < obj elt)
                (bst-find obj (node-l bst) <)
                (bst-find obj (node-r bst) <))))))

(defun bst-min (bst)
  (and bst
       (or (bst-min (node-l bst)) bst)))

(defun bst-max (bst)
  (and bst
       (or (bst-max (node-r bst)) bst)))

(defun bst-remove (obj bst <)
  (if (null bst)
      nil
      (let ((elt (node-elt bst)))
    (if (eql obj elt)
        (percolate bst)</pre>e
        (if (funcall < obj elt)
        (make-node
         :elt elt
         :l (bst-remove obj (node-l bst) <)
         :r (node-r bst))
        (make-node
         :elt elt
         :r (bst-remove obj (node-r bst) <)
         :l (node-l bst)))))))

(defun percolate (bst)
  "percolate [ˈpɜ:kəˌleɪt] /remove root/
   vb
   1) to cause (a liquid) to pass through a fine mesh, porous substance, etc.,
      or (of a liquid) to pass through a fine mesh, porous substance, etc.; trickle"
  (let ((l (node-l bst)) (r (node-r bst)))
    (cond ((null l) r)
	  ((null r) l)
	  (t (if (zerop (random 2))
		 (make-node :elt (node-elt (bst-max l))
			    :r r
			    :l (bst-remove-max l))
		 (make-node :elt (node-elt (bst-min r))
			    :r (bst-remove-min r)
			    :l l))))))

(defun bst-remove-min (bst)
  (if (null (node-l bst))
      (node-r bst)
      (make-node :elt (node-elt bst)
         :l (bst-remove-min (node-l bst))
         :r (node-r bst))))

(defun bst-remove-max (bst)
  (if (null (node-r bst))
      (node-l bst)
      (make-node :elt (node-elt bst)
		 :l (node-l bst)
		 :r (bst-remove-max (node-r bst)))))

(defun bst-traverse (fn bst)
  (when bst ;中序遍历
    (bst-traverse fn (node-l bst))
    (funcall fn (node-elt bst))
    (bst-traverse fn (node-r bst))))

** TODO 4.8 哈希表 (Hash Table)

** Chapter 4 习题 (Exercises)

*** 1 定义一个函数，接受一个平方数组square array，一个相同维度的数组 (n n)，并将它顺时针转 90 度。

(defun quarter-turn (arr)
  "把一个二维正方形数组顺时针旋转90度"
  (let ((length (car (array-dimensions arr))))
    (labels ((index-to-go (lst)
	       (list (cadr lst) (- length (car lst) 1)))
	     (turn (i j)
	       (let* ((temp nil)
		      (pos0 (list i j))
		      (pos1 (index-to-go pos0))
		      (pos2 (index-to-go pos1))
		      (pos3 (index-to-go pos2)))
		 (setf temp (aref arr (first pos3) (second pos3)))
		 (setf (aref arr (first pos3) (second pos3))
		       (aref arr (first pos2) (second pos2)))
		 (setf (aref arr (first pos2) (second pos2))
		       (aref arr (first pos1) (second pos1)))
		 (setf (aref arr (first pos1) (second pos1))
		       (aref arr (first pos0) (second pos0)))
		 (setf (aref arr (first pos0) (second pos0))
		       temp)
		 nil)))
      (dotimes (i (ceiling (/ length 2)))
	(dotimes (j (floor (/ length 2)))
	  (format t "i is ~A and j is ~A~%" i j)
	  (turn i j)))
      arr)))

(quarter-turn #2A((aa ab ac ad) (ba bb bc bd) (ca cb cc cd) (da db dc dd)))

*** 2 阅读 368 页的 reduce 说明，然后用它来定义：

(a) copy-list

(b) reverse (针对列表) 

(defun my-reverse (lst) (reduce #'(lambda (a b) (if (listp a) (cons b a) (list b a))) lst))

;; test (my-reverse '(1 2 3 4))

(defun my-copy-list (lst)
  (reduce #'(lambda (a b)
	      (if (listp a)
		  (append a (list b))
		  (list a b))) lst))

;; test:

(let ((ori '(a b c)))
  (let ((new (my-copy-list ori)))
    (setf (car ori) 'new)
    (format t "~A" ori)
    new))

*** 3 定义一个结构来表示一棵树，其中每个节点包含某些数据及三个小孩。定义：

(a) 一个函数来复制这样的树（复制完的节点与本来的节点是不相等 (`eql)

(b) 一个函数，接受一个对象与这样的树，如果对象与树中各节点的其中一个字段相等时，返回真。 

(defstruct (my-tree (:print-function print-my-tree)) node (a nil) (b nil) (c nil))

(defun print-my-tree (tree stream depth)
  (format stream "(~A" ( my-tree-node tree))
  (when (not (null (my-tree-a tree)))
    (format stream "~A" (my-tree-a tree)))
  (when (not (null (my-tree-b tree)))
    (format stream "~A" (my-tree-b tree)))
  (when (not (null (my-tree-c tree)))
    (format stream "~A" (my-tree-c tree)))
  (format stream ")"))

(setf tree-b (make-my-tree :node 'child-b))

(setf tree-c (make-my-tree :node 'child-c))

(setf tree-a-a (make-my-tree :node 'child-a-a))

(setf tree-a (make-my-tree :node 'child-a :a tree-a-a))

(setf tree (make-my-tree :node 'root :a tree-a :b tree-b :c tree-c))

(defun my-copy-tree (tree)
  (let ((node (my-tree-node tree))
	(a (my-tree-a tree))
	(b (my-tree-b tree))
	(c (my-tree-c tree)))
    (make-my-tree :node node
		  :A (if (null a)
			 nil
			 (my-copy-tree a))
		  :B (if (null b)
			 nil
			 (my-copy-tree b))
		  :c (if (null c)
			 nil
			 (my-copy-tree c)))))

(setf new-tree (my-copy-tree tree))

(eql (my-tree-a tree) (my-tree-a new-tree))

;nil

(eql (my-tree-node tree) (my-tree-node new-tree))

;T

(defun my-tree-search (node tree)
  (cond ((null tree) nil)
	(t
	  (let ((tree-node (my-tree-node tree))
		(a (my-tree-a tree))
		(b (my-tree-b tree))
		(c (my-tree-c tree)))
	    (if (equal node tree-node)
		T
		(or (my-tree-search node a)
		    (my-tree-search node b)
		    (my-tree-search node c)))))))

new-tree

(my-tree-search 'child-a-a new-tree)

*** 4 定义一个函数，接受一棵二叉搜索树，并返回由此树元素所组成的，一个由大至小排序的列表。

(setf nums nil)

(dolist (x '(5 8 4 2 1 9 6 7 3))
  (setf nums (bst-insert x nums #'<)))

(defun full-print-node (node)
  (if (null node)
      "NIL"
      (let ((elt (node-elt node))
	    (l (node-l node))
	    (r (node-r node)))
	(format nil
		"(~A ~A ~A)"
		elt
		(full-print-node l)
		(full-print-node r)))))

(full-print-node nums)

(defun sort-bst (bst &key (order 'ascendant))
  (if (null bst)
      nil
      (let ((elt (node-elt bst))
	    (l (node-l bst))
	    (r (node-r bst)))
	(cond ((equal order 'ascendant)
	   (append (sort-bst l) (list elt) (sort-bst r)))
	  ((equal order 'descendant)
	   (append (sort-bst r :order 'descendant) (list elt) (sort-bst l :order 'descendant)))
	  (t nil)))))

(sort-bst nums :order 'descendant)

*** 5 定义 bst-adjoin 。这个函数应与 bst-insert 接受相同的参数，但应该只在对象不等于任何树中对象时将其插入。

勘误: bst-adjoin 的功能与 bst-insert 一模一样。

*** TODO 6 任何哈希表的内容可以由关联列表（assoc-list）来描述，其中列表的元素是 (k . v) 的形式，对应到哈希表中的每一个键值对。定义一个函数：

(a) 接受一个关联列表，并返回一个对应的哈希表。

(b) 接受一个哈希表，并返回一个对应的关联列表。

*** Time-stamp: <2013-04-27 Sat>