ANSI Common Lisp 第四章习题解

1. Define a function to take a square array (an array whose dimensions

are (n n)) and rotate it 90° clockwise:

> (quarter-turn #2A((a b) (c d)))

#2A((C A) (D B))
You'll need array-dimensions (page 361).

2. Read the description of reduce on page 368, then use it to define:

(a) c o p y - l i s t

(b) r e v e r s e (for lists)

;;; copy list using reduce
(defun our-copy-list (xs)
(reduce #'cons xs
:initial-value nil
:from-end t))
;;;; test our-copy-list
(out-copy-list '(1 2 3))

(defun our-reverse (xs)
"reverse function using reduce"
(reduce #'(lambda (acc x)
(cons x acc))
xs
:initial-value nil))
(our-reverse '(1 2 3))

3. Define a structure to represent a tree where each node contains some

data and has up to three children. Define

(a) a function to copy such a tree (so that no node in the copy is eql

to a node in the original)

(b) a function that takes an object and such a tree, and returns true if

the object is eql to the data field of one of the nodes

(defstruct node3
(left nil)
(mid nil)
(right nil)
(val nil))

(defun node3-copy-tree (tr)
(or (null tr)
(make-node3
:left (node3-copy-tree (node3-left tr))
:right (node3-copy-tree (node3-right tr))
:mid (node3-copy-tree (node3-mid tr))
:val (node3-val tr))))

(defparameter *dummy-node*
(make-node3
:left (make-node3 :val 1)
:mid (make-node3 :val 2)
:right (make-node3 :val 3)
:val 4))

(defun node3-look (tr val)
(and (not (null tr))
(or (eql (node3-val tr) val)
(node3-look (node3-left tr) val)
(node3-look (node3-right tr) val)
(node3-look (node3-mid tr) val)))

(node3-look *dummy-node* 5)

(node3-copy-tree *dummy-node*)

(defun map-node3 (fn tr0 tr1)
(cond
((null tr0) '())
((null tr1) '())
(t (append
(list (funcall fn tr0 tr1))
(list
(map-node3 fn (node3-left tr0) (node3-left tr1))
(map-node3 fn (node3-mid tr0) (node3-mid tr1))
(map-node3 fn (node3-right tr0) (node3-right tr1)))))))

(map-node3 #'(lambda (x y)
(cons (node3-val x)
(node3-val y)))
*dummy-node* (node3-copy-tree *dummy-node*))

(map-node3 #'eql *dummy-node* (node3-copy-tree *dummy-node*))

;;;; 4. Define a function that takes a BST and returns a list of its
;;;; elements ordered from greatest to least.
(defstruct BST
(left nil)
(right nil)
(val nil))

(defun BST-insert (tr val)
(if (null tr)
(make-BST :val val)
(if (> val (BST-val tr))
(make-BST
:left (BST-left tr)
:right (BST-insert (BST-right tr) val)
:val (BST-val tr))
(make-BST
:left (BST-insert (BST-left tr) val)
:right (BST-right tr)
:val (BST-val tr)))))

(defun BST-travel (fn tr)
(or (null tr)
(progn
(BST-travel fn (BST-right tr))
(funcall fn (BST-val tr))
(BST-travel fn (BST-left tr)))))

(BST-travel
#'(lambda(el)
(format t "~A " el))
(BST-insert
(BST-insert
(BST-insert
(BST-insert nil 10)
5)
7)
4))

;; 5. Define bst-adjoin. This function should take the same arguments as
;; bst-insert, but should only insert the object if there is nothing eql
;; to it in the tree.
(defun BST-isleaf (node)
(and (typep node 'BST)
(not (null node))
(null (BST-left node))
(null (BST-left node))))
(BST-isleaf (make-BST))

(defun BST-adjoin (tr val)
(if (null tr)
(make-BST :val val)
(if (and (BST-isleaf tr)
(eql val (BST-val tr)))
(make-BST :val (BST-val tr))
(if (> val (BST-val tr))
(make-BST
:left (BST-left tr)
:right (BST-adjoin (BST-right tr) val)
:val (BST-val tr))
(make-BST
:left (BST-adjoin (BST-left tr) val)
:right (BST-right tr)
:val (BST-val tr))))))

(BST-adjoin
(BST-adjoin
(BST-adjoin
(BST-adjoin
(BST-adjoin NIL 5)
7)
4)
4)
6)

;;6. The contents of any hash table can be described by an assoc-list whose
;;elements are (k . v), for each key-value pair in the hash table. Define
;;a function that
;;(a) takes an assoc-list and returns a corresponding hash table
;;(b) takes a hash table and returns a corresponding assoc-list
(defun hash-2-assoc (dict)
(let ((as '()))
(maphash #'(lambda (k v)
(setf as (cons (cons k v) as)))
dict)
as))

(defun assoc-2-hash (as)
(let ((hash (make-hash-table)))
(mapcar #'(lambda (pair)
(setf (gethash (car pair) hash)
(cdr pair)))
as)
hash))

(defun create-hash ()
(let ((hash (make-hash-table)))
(progn
(setf (gethash 'color hash) 'yellow)
(setf (gethash 'sex hash) 'male)
(setf (gethash 'name hash) 'cj)
hash)))

(create-hash)
(hash-2-assoc (create-hash))