ITコンサルの日常

ITコンサル会社に勤務する普通のITエンジニアの日常です。

「ANSI Common Lisp」4章練習問題

Lisp

1. 正方の配列(大きさが(n n)の配列)を引数としてそれを90度、時計回りに回転させる関数を定義せよ。

ちょ。いきなり難しいなあ。
思いっきり手続き言語っぽいが、とりあえずできた。

(defun quarter-turn (arr2d)
  (let ((arr2d-dimensions (array-dimensions arr2d)))
    (let ((result-arr (make-array (reverse arr2d-dimensions))))
      (do ((i 0 (+ i 1)))
          ((> i (- (first arr2d-dimensions) 1)) result-arr)
        (do ((j 0 (+ j 1)))
            ((> j (- (second arr2d-dimensions) 1)) result-arr)
          (setf (aref result-arr j (- (first arr2d-dimensions) i 1)) (aref arr2d
 i j)))))))

(quarter-turn #2a((a b) (c d)))
(quarter-turn #2a((a b c) (d e f)))

結果はこう。

* 
QUARTER-TURN
* 
#2A((C A) (D B))
* 
#2A((D A) (E B) (F C))
*

2. reduceを使って以下のものを定義せよ

(a) copy-list
(defun my-copy-list (lst)
  (reduce #'cons lst :from-end t :initial-value nil))

(copy-list '(a b c))
(my-copy-list '(a b c))

短い。やっぱりreduce威力絶大な感じ。
結果はこう。

* 
MY-COPY-LIST
* 
(A B C)
* 
(A B C)
*
(b) reverse(リストが対象)
(defun my-reverse (lst)
  (reduce #'(lambda (x y) (cons y x)) lst :initial-value nil))

(reverse '(a b c))
(my-reverse '(a b c))

結果はこう。

* 
MY-REVERSE
* 
(C B A)
* 
(C B A)
*

3. それぞれのノードがデータをもち、3つまでの子がとれるようなツリーを表現するストラクチャを定義した上で、以下の関数を定義せよ。

とりあえずストラクチャを定義。

(defstruct my-node elt (l nil) (c nil) (r nil))

; 1 --- 2
;    |
;    -- 3 --- 5
;    |     |
;    |     -- 6
;    |     |
;    |     -- 7
;    | 
;    -- 4
(setf root-node (make-my-node :elt 1))
(setf (my-node-l root-node) (make-my-node :elt 2))
(setf (my-node-c root-node) (make-my-node :elt 3))
(setf (my-node-r root-node) (make-my-node :elt 4))

(setf center-node (my-node-c root-node))
(setf (my-node-l center-node) (make-my-node :elt 5))
(setf (my-node-c center-node) (make-my-node :elt 6))
(setf (my-node-r center-node) (make-my-node :elt 7))

root-node

結果はこう。

#S(MY-NODE
     :ELT 1
     :L #S(MY-NODE :ELT 2 :L NIL :C NIL :R NIL)
     :C #S(MY-NODE
             :ELT 3
             :L #S(MY-NODE :ELT 5 :L NIL :C NIL :R NIL)
             :C #S(MY-NODE :ELT 6 :L NIL :C NIL :R NIL)
             :R #S(MY-NODE :ELT 7 :L NIL :C NIL :R NIL))
     :R #S(MY-NODE :ELT 4 :L NIL :C NIL :R NIL))

わりと見やすい形で表示される。

(a) このようなツリーをコピーする関数(コピーのノードがオリジナルのノードとeqlにならないように)
(defun copy-my-node (node)
  (if node
     (let ((copy-node (make-my-node :elt (my-node-elt node))))
        (setf (my-node-l copy-node) (copy-my-node (my-node-l node)))
        (setf (my-node-c copy-node) (copy-my-node (my-node-c node)))
        (setf (my-node-r copy-node) (copy-my-node (my-node-r node)))
        copy-node)
     nil))

(copy-my-node root-node)
(format t "(eql root-node copy-node) = ~A~%" (eql root-node (copy-my-node root-n
ode)))

結果はこう。

#S(MY-NODE
     :ELT 1
     :L #S(MY-NODE :ELT 2 :L NIL :C NIL :R NIL)
     :C #S(MY-NODE
             :ELT 3
             :L #S(MY-NODE :ELT 5 :L NIL :C NIL :R NIL)
             :C #S(MY-NODE :ELT 6 :L NIL :C NIL :R NIL)
             :R #S(MY-NODE :ELT 7 :L NIL :C NIL :R NIL))
     :R #S(MY-NODE :ELT 4 :L NIL :C NIL :R NIL))
* (eql root-node copy-node) = NIL
NIL
(b) オブジェクトとこのようなツリーを引数として、オブジェクトがツリーのノードのデータフィールドにeqlであるときに真を返す関数
(defun find-my-node (obj node)
  (if node
     (if (eql obj (my-node-elt node))
        T
        (or (find-my-node obj (my-node-l node))
            (find-my-node obj (my-node-c node))
            (find-my-node obj (my-node-r node))))
     nil))

(find-my-node 5 root-node)
(find-my-node 8 root-node)

結果はこう。

* 
T
* 
NIL
*

4. BSTを引数として、要素を最大から最小まで並べて返す関数を定義せよ。

bst-traverseを改造(3行目と5行目を入れ替える)するだけ。超簡単でびびった。

(defstruct node 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)
        bst
        (if (funcall < obj elt)
          (make-node
            :elt elt
            :l   (bst-insert obj (node-l bst) <)
            :r   (node-r bst))
          (make-node
            :elt elt
            :r   (bst-insert obj (node-r bst) <)
            :l   (node-l bst)))))))

(defun bst-traverse (fn bst)
  (when bst
    (bst-traverse fn (node-r bst))
    (funcall fn (node-elt bst))
    (bst-traverse fn (node-l bst))))

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

nums
(bst-traverse #'princ nums)

結果はこう。

* 
#S(NODE
     :ELT 5
     :L #S(NODE
             :ELT 4
             :L #S(NODE
                     :ELT 2
                     :L #S(NODE :ELT 1 :L NIL :R NIL)
                     :R #S(NODE :ELT 3 :L NIL :R NIL))
             :R NIL)
     :R #S(NODE
             :ELT 8
             :L #S(NODE :ELT 6 :L NIL :R #S(NODE :ELT 7 :L NIL :R NIL))
             :R #S(NODE :ELT 9 :L NIL :R NIL)))
* 987654321
NIL
*

5. bst-adjoinを定義せよ。この関数はbst-insertと同じ引数を取るが、ツリーにeqlとなるものがないときに限ってそのオブジェクトを挿入する。

試しに現状のbst-insertで重複要素を入れてみる。

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

nums

結果はこう。

#S(NODE
     :ELT 5
     :L #S(NODE
             :ELT 4
             :L #S(NODE
                     :ELT 2
                     :L #S(NODE :ELT 1 :L NIL :R NIL)
                     :R #S(NODE :ELT 3 :L NIL :R NIL))
             :R NIL)
     :R #S(NODE
             :ELT 8
             :L #S(NODE :ELT 6 :L NIL :R #S(NODE :ELT 7 :L NIL :R NIL))
             :R #S(NODE :ELT 9 :L NIL :R NIL)))

あれ? 7を重複要素として入れてみたつもりが、重複してません。
bst-insertを良く見てみると、

      (if (eql obj elt)
        bst

の判定が入っているので、既に考慮が入っているということですね。
なーんだ。

で、訳注見てみると、

この関数は実質的にbst-insertと同じになる (原著者ホームページ参照)。

とのことで、同じみたいです。


逆に、この判定をはずしたバージョンで試してみる。

(defun bst-insert (obj bst <)
  (if (null bst)
    (make-node :elt obj)
    (let ((elt (node-elt bst)))
        (if (funcall < obj elt)
          (make-node
            :elt elt
            :l   (bst-insert obj (node-l bst) <)
            :r   (node-r bst))
          (make-node
            :elt elt
            :r   (bst-insert obj (node-r bst) <)
            :l   (node-l bst))))))

結果はこう。

#S(NODE
     :ELT 5
     :L #S(NODE
             :ELT 4
             :L #S(NODE
                     :ELT 2
                     :L #S(NODE :ELT 1 :L NIL :R NIL)
                     :R #S(NODE :ELT 3 :L NIL :R NIL))
             :R NIL)
     :R #S(NODE
             :ELT 8
             :L #S(NODE
                     :ELT 6
                     :L NIL
                     :R #S(NODE
                             :ELT 7
                             :L NIL
                             :R #S(NODE :ELT 7 :L NIL :R NIL)))
             :R #S(NODE :ELT 9 :L NIL :R NIL)))

>=の場合右ノードに入れることになるので、この場合では正しい結果ですね。

6. ハッシュ表の内容は、キー・値の各ペアを要素(k,v)で保持する連想リストによって記述できる。以下の関数を定義せよ。

(a) 連想リストを引数として対応するハッシュ表を返す。
(b) ハッシュ表を引数として対応する連想リストを返す。
; 連想リストをハッシュ表に変換する
(defun assoc-list-to-hashtable (al)
  (if al
    (let ((result (make-hash-table)))
      (mapcar #'(lambda (lst) (setf (gethash (car lst) result) (last lst))) al)
      result)
    nil))

; ハッシュ表を連想リストに変換する
(defun hashtable-to-assoc-list (ht)
  (if ht
    (let ((result nil))
      (maphash
        #'(lambda (k v)
          (if (consp v)
            (setf result (cons (list k (car v)) result))
            (setf result (cons (list k v) result))))
        ht)
      result)
    nil))

; ハッシュ表を表示する(デバッグ用)
(defun print-hashtable (ht)
  (maphash #'(lambda (k v) (format t "~A = ~A~%" k v)) ht))

; 連想リストを表示する(デバッグ用)
(defun print-assoc-list (al)
  (mapcar #'(lambda (lst) (format t "~A = ~A~%" (car lst) (last lst))) al))

(setf ht (assoc-list-to-hashtable '(("+" "plus") ("-" "minus"))))
(print-hashtable ht)
(print-assoc-list (hashtable-to-assoc-list ht))

結果はこう。

* Warning:  Declaring HT special.

#<EQL hash table, 2 entries {5801D9D5}>
* + = (plus)
- = (minus)
NIL
* - = (minus)
+ = (plus)
(NIL NIL)