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))