M.Hiroi's Home Page

Common Lisp Programming

Yet Another Common Lisp Problems

[ PrevPage | Common Lisp | NextPage ]

●問題26

リスト ls を木とみなして、x と等しい要素 (葉) を探す関数 member-tree x ls を定義してください。

> (member-tree 'd '(a (b (c (d . e) f) g) h))
t
> (member-tree 'e '(a (b (c (d . e) f) g) h))
t
> (member-tree 'x '(a (b (c (d . e) f) g) h))
nil

解答

●問題27

リストを木とみなして、要素 (葉) を数える関数 count-leaf を定義してください。

> (count-leaf '(a (b (c (d . e) f) g) h))
8

解答

●問題28

リスト ls を木とみなして、y と等しい要素を x に置換する関数 subst x y ls を定義してください。Common Lisp には同等の機能を持つ関数 subst があるので、ここでは関数名を my-subst としました。

> (my-subst 'x 'a '(a (b (a (c . a) d) a) e))
(x (b (x (c . x) d) x) e)

解答

●問題29

リスト ls から n 個の要素を選ぶ順列を求める関数 permutation n ls を定義してください。なお、生成した順列はリストに格納して返すものとします。

> (permutation 3 '(a b c))
((a b c) (a c b) (b a c) (b c a) (c a b) (c b a))

解答

●問題30

リスト ls から重複を許して n 個の要素を選ぶ順列を求める関数 repeat-perm n ls を定義してください。なお、生成した順列はリストに格納して返すものとします。

> (repeat-perm 3 '(a b c))
((a a a) (a a b) (a a c) (a b a) (a b b) (a b c) (a c a) (a c b) (a c c) (b a a)
 (b a b) (b a c) (b b a) (b b b) (b b c) (b c a) (b c b) (b c c) (c a a) (c a b)
 (c a c) (c b a) (c b b) (c b c) (c c a) (c c b) (c c c))

解答

●問題31

n 個の中から r 個を選ぶ組み合わせの数 nr を求める関数 comb-num n r を定義してください。

> (comb-num 5 3)
10
> (comb-num 10 5)
252

解答

●問題32

リスト ls から n 個の要素を選ぶ組み合わせを求める関数 combination n ls を定義してください。なお、生成した組み合わせはリストに格納して返すものとします。

> (combination 3 '(a b c d e))
((a b c) (a b d) (a b e) (a c d) (a c e) (a d e) (b c d) (b c e) (b d e) (c d e))

解答

●問題33

リスト ls から重複を許して n 個の要素を選ぶ組み合わせを求める関数 repeat-comb n ls を定義してください。

> (repeat-comb 3 '(a b c d))
((a a a) (a a b) (a a c) (a a d) (a b b) (a b c) (a b d) (a c c) (a c d) (a d d)
 (b b b) (b b c) (b b d) (b c c) (b c d) (b d d) (c c c) (c c d) (c d d) (d d d))

解答

●問題34

リスト ls を n 番目の要素で二分割する関数 split-nth ls n を定義してください。なお、分割したリストは多値で返すものとします。

> (split-nth '(a b c d e f) 3)
(a b c)
(d e f)
> (split-nth '(a b c d e f) 4)
(a b c d)
(e f)

解答

●問題35

リストを奇数番目の要素と偶数番目の要素に分ける関数 partition を定義してください。なお、分割したリストは多値で返すものとします。

> (partition '(a b c d e f g))
(a c e g)
(b d f)

解答

●問題36

x と等しい要素の位置でリスト ls を二分割する関数 split-find x ls を定義してください。なお、分割したリストは多値で返すものとします。

> (split-find 'c '(a b c d e f))
(a b)
(c d e f)

解答

●問題37

リスト ls を x よりも大きい要素と x 以下の要素に分ける関数 split-ge x ls を定義してください。なお、分割したリストは多値で返すものとします。

> (split-ge 5 '(4 6 3 5 7 8 2 9 1))
(4 3 2 1)
(6 5 7 8 9)

解答

●問題38

リストの中で連続した等しい記号を部分リストにまとめる関数 pack を定義してください。

> (pack '(a a a b b c c c c d e e e e e))
((a a a) (b b) (c c c c) (d) (e e e e e))

解答

●問題39

整列済みの整数を表すリストで、連続している部分列を (start . end) に置き換える関数 pack-num-list を定義してください。start は部分列の始点、end は部分列の終点を表します。

> (pack-num-list '(1 2 3 5 7 8 10))
((1 . 3) 5 (7 . 8) 10)

なお、この問題は下記サイトを参考にさせていただきました。関係各位に感謝いたします。

解答

●問題40

問題 39 の逆変換を行う関数 expand-num-list を定義してください。

> (expand-num-list '((1 . 3) 5 (7 . 8) 10))
(1 2 3 5 7 8 10)

解答

●問題41

連続している同じ記号を (code . num) に変換する関数 encode を定義してください。code は記号、num は個数を表します。このような変換を「ランレングス符号化」といいます。

> (encode '(a a a b b c d d d d d e))
((a . 3) (b . 2) (c . 1) (d . 5) (e . 1))

解答

●問題42

問題 41 の逆変換を行う関数 decode を定義してください。

> (decode '((a . 3) (b . 2) (c . 1) (d . 5) (e . 1)))
(a a a b b c d d d d d e)

解答

●問題43

リストの要素に述語 pred を適用し、一つでも真を返す要素があれば真を返す関数 any と、一つでも偽を返す要素があれば偽を返す (全てが真の場合に真を返す) 関数 every を定義してください。Common Lisp には any と同等の機能を持つ関数 some があります。また、同名の関数 every もあるので、ここでは関数名を my-every としました。

> (any #'evenp '(1 3 5 7 9))
nil
> (any #'evenp '(1 3 4 5 7 9))
t
> (my-every #'evenp '(2 4 6 8 10))
t
> (my-every #'evenp '(2 4 6 5 8 10))
nil

解答

●問題44

mapcar f xs はリスト xs の要素に関数 f を適用します。関数 maplist は関数 f にリストそのものを渡します。ただし、繰り返すたびにリストの先頭要素は取り除かれていきます。関数 maplist を定義してください。なお、Common Lisp には maplist があるので、ここでは関数名を my-maplist としました。

> (my-maplist #'(lambda (x) x) '(a b c d e))
((a b c d e) (b c d e) (c d e) (d e) (e))
> (my-maplist #'(lambda (x) (fold + 0 x)) '(1 2 3 4 5))
(15 14 12 9 5)

解答

●問題45

リスト操作を一般化した関数 for-each-list fn comb term xs を定義してください。ここで、fn はリストの要素に適用する関数、comb は関数の返り値を結合する関数、term は終端の値、xs がリストです。

> (for-each-list #'(lambda (x) x) + 0 '(1 2 3 4 5))
15
> (for-each-list #'(lambda (x) (* x x)) + 0 '(1 2 3 4 5))
55
> (for-each-list #'(lambda (x) x) append '() '((a b) (c d e) () (f g)))
(a b c d e f g)

解答

●問題46

関数 for-each-list を使ってマッピング、フィルター、畳み込みを行う関数を定義してください。

解答

●問題47

パズル「小町分数」を解くプログラムを作ってください。

[問題] 小町分数

下図の A から I の場所に 1 から 9 までの数字をひとつずつ配置します。3 つの分数を足すと 1 / N になる配置を求めてください。

     A     D     G     1
    --- + --- + --- = ---
    B C   E F   H I    N

ex)  3 / 27 + 6 / 54 + 9 / 81 = 1 / 3 
     3 / 54 + 6 / 72 + 9 / 81 = 1 / 4

        図 : 小町分数

このパズルの元ネタは N = 1 の場合で、参考文献 [1] に掲載されています。

解答

-- 参考文献 ------
[1] 芦ヶ原伸之,『超々難問数理パズル 解けるものなら解いてごらん』, 講談社, 2002

●問題48

3 行 3 列の魔方陣を解くプログラムを作ってください。

[問題] 魔方陣

          図 : 魔方陣

上図の A から I の場所に 1 から 9 までの数字をひとつずつ配置します。縦横斜めの合計が等しくなるように数字を配置してください。

解答

●問題49

計算式の数字を文字や記号に置き換えて、それを元の数字に戻すパズルを「覆面算」といいます。異なる文字は異なる数字を表し、同じ文字は同じ数字を表します。覆面算 WRONG * M = RIGHT を解くプログラムを作ってください。なお、今回は使用する数字を 1 から 9 までとします。

   W R O N G
 *         M
 ------------
   R I G H T

図 : 小町覆面算

解答

●問題50

自然数 n 以下の素数をすべて求める関数 sieve を作ってください。

> (sieve 100)
(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97)

解答


●解答26

リスト : 木の探索

(defun member-tree (x ls)
  (labels ((iter (ls)
             (cond ((consp ls)
                    (iter (car ls))
                    (iter (cdr ls)))
                   ((eql ls x)
                    (return-from member-tree t))
                   (t nil))))
    (iter ls)))

; 別解 (CPS)
(defun member-tree1 (x ls)
  (labels ((iter (ls cont)
             (cond ((consp ls)
                    (iter (car ls)
                          #'(lambda (y) (iter (cdr ls)
                                              #'(lambda (z) (funcall cont z))))))
                   ((eql x ls) t)
                   (t (funcall cont nil)))))
    (iter ls #'identity)))

探索は局所関数 iter で行います。リストを二分木と考えると、リストの先頭要素が左部分木、残りのリストが右部分木に相当します。左右の部分木に対して iter を再帰呼び出しすればいいわけです。x と等しい要素を見つけたならば、return-from を呼び出して t を返します。そうでなければ、else 節で nil を返します。

別解は継続渡しスタイル (Continuation Passing Style : CPS) で書き直したものです。

●解答27

リスト : 葉の個数を求める

(defun count-leaf (ls)
  (cond ((null ls) 0)
        ((atom ls) 1)
        (t (+ (count-leaf (car ls))
              (count-leaf (cdr ls))))))

; 別解 (CPS)
(defun count-leaf1 (ls)
  (labels ((iter (ls cont)
             (cond ((null ls) (funcall cont 0))
                   ((atom ls) (funcall cont 1))
                   (t (iter (car ls)
                            #'(lambda (a)
                                (iter (cdr ls)
                                      #'(lambda (b)
                                          (funcall cont (+ a b))))))))))
    (iter ls #'identity)))

count-leaf も簡単です。ls が空リストならば 0 を返します。(atom ls) が真ならば葉なので 1 を返します。それ以外の場合、ls はコンスセルなので、左右の部分木にたいして count-leaf を再帰呼び出しし、その結果を足し算して返します。別解は継続渡しスタイル (Continuation Passing Style : CPS) で書き直したものです。

●解答28

リスト : 木の置換

(defun my-subst (x y ls)
  (cond ((eql y ls) x)
        ((atom ls) ls)
        (t (cons (my-subst x y (car ls))
                 (my-subst x y (cdr ls))))))

; 別解 (CPS)
(defun my-subst1 (x y ls)
  (labels ((iter (ls cont)
             (cond ((eql y ls) (funcall cont x))
                   ((atom ls) (funcall cont ls))
                   (t
                    (iter (car ls)
                          #'(lambda (a)
                              (iter (cdr ls)
                                    #'(lambda (b)
                                        (funcall cont (cons a b))))))))))
    (iter ls #'identity)))

my-subst も簡単です。ls が y と等しい場合は x を返します。(atom ls) が真の場合は ls をそのまま返します。ls がコンスセルならば左右の部分木にたいして subst を再帰呼び出しし、その結果を cons で連結して返します。別解は継続渡しスタイル (Continuation Passing Style : CPS) で書き直したものです。

●解答29

リスト : 順列の生成

; mapcar の結果を平坦化する
(defun flatmap (func ls)
  (apply #'append (mapcar func ls)))

; 順列をリストに格納して返す
(defun permutation (n ls)
  (if (zerop n)
      (list nil)
    (flatmap #'(lambda (x)
                 (mapcar #'(lambda (y) (cons x y))
                         (permutation (1- n) (remove x ls))))
             ls)))

; 別解
(defun permutation1 (n ls)
  (labels ((perm-sub (n ls a b)
             (if (zerop n)
                 (cons (reverse a) b)
               (reduce #'(lambda (y x)
                           (perm-sub (1- n) (remove x ls) (cons x a) y))
                       ls
                       :initial-value b))))
    (perm-sub n (reverse ls) nil nil)))

関数 permutation は引数のリスト ls から n 個を選ぶ順列を生成し、それをリストに格納して返します。n が 0 のときが再帰の停止条件で、空リストを格納したリストを返します。このリストに対して要素を追加します。この処理は mapcar を二重に使うと簡単に実現できます。このとき、リストを平坦化します。これを関数 flatmap で行っています。

あとはラムダ式の中で permutation を再帰呼び出しをして、n - 1 個を選ぶ順列を生成します。そして、その返り値にリスト ls の要素 x を追加すれば、n 個を選ぶ順列を生成することができます。別解は flatmap を使わないで、局所関数 perm-sub で順列を生成します。

●解答30

リスト : 重複順列

(defun repeat-perm (n ls)
  (if (zerop n)
      (list nil)
    (flatmap #'(lambda (x)
                 (mapcar #'(lambda (y) (cons x y))
                         (repeat-perm (1- n) ls)))
             ls)))

; 別解
(defun repeat-perm1 (n ls)
  (labels ((perm-sub (n ls a b)
             (if (zerop n)
                 (cons (reverse a) b)
               (reduce #'(lambda (y x)
                           (perm-sub (1- n) ls (cons x a) y))
                       ls
                       :initial-value b))))
    (perm-sub n (reverse ls) nil nil)))

重複順列も簡単です。選んだ要素を取り除く必要がないので、repeat-perm を再帰呼び出しするとき、リスト ls をそのまま渡すだけです。別解は flatmap を使わないで、局所関数 perm-sub で重複順列を生成します。

●解答31

組み合わせの数を nr と表記します。nr を求めるには、次の公式を使えば簡単です。

nr = n * (n - 1) * (n - 2) * ... * (n - r + 1) / (1 * 2 * 3 * ... * r)

皆さんお馴染みの公式ですね。この公式をそのままプログラムすることもできますが、次の式を使うともっと簡単にプログラムできます。

n0 = nn = 1
nr = nr-1 * (n - r + 1) / r

この式は nrnr-1 の関係を表しています。あとは再帰定義を使って簡単にプログラムできます。

リスト : 組み合わせの数

(defun comb-num (n r)
  (if (or (= n r) (zerop r))
      1
    (/ (* (comb-num n (1- r)) (1+ (- n r))) r)))

●解答32

組み合わせの生成は、次に示す組み合わせの公式と同じ考え方でプログラムすることができます。

n0 = nn = 1
nr = n-1r-1 + n-1r

プログラムは次のようになります。

リスト : 組み合わせの生成

(defun combination (n ls)
  (labels ((comb-sub (n ls)
             (cond ((zerop n) (list nil))
                   ((= n (length ls)) (list ls))
                   (t
                    (append (mapcar #'(lambda (x) (cons (car ls) x))
                                    (comb-sub (1- n) (cdr ls)))
                            (comb-sub n (cdr ls)))))))
    (if (< (length ls) n)
        nil
      (comb-sub n ls))))

; 別解
(defun combination1 (n ls)
  (labels ((comb-sub (n ls a b)
             (cond ((zerop n) (cons (reverse a) b))
                   ((= (length ls) n)
                    (cons (append (reverse a) ls) b))
                   (t
                    (comb-sub (1- n)
                              (cdr ls)
                              (cons (car ls) a)
                              (comb-sub n (cdr ls) a b))))))
    (if (< (length ls) n)
        nil
      (comb-sub n ls nil nil))))

実際の処理は局所関数 comb-sub で行います。最初の節は個数 n が 0 の場合です。選択する要素がないので空リストを格納したリストを返します。次の節で、n と ls の要素数が同じ場合は、その要素を全て選択するので ls をリストに格納して返します。

そうでなければ、先頭要素 (car ls) を選びます。残りのリスト (cdr ls) から n - 1 個を選ぶ組み合わせを生成して、その先頭に (car ls) を追加します。あとは、(cdr ls) から n 個を選ぶ組み合わせを combination で求めて、関数 append で連結するだけです。別解は局所関数 comb-sub の引数 a に選んだ要素を格納し、引数 b に完成した組み合わせを格納します。

●解答33

リスト : 重複組み合わせ

(defun repeat-comb (n ls)
  (cond ((zerop n) (list nil))
        ((singlep ls) (list (make-list n :initial-element (car ls))))
        (t
         (append (mapcar #'(lambda (x) (cons (car ls) x))
                         (repeat-comb (1- n) ls))
                 (repeat-comb n (cdr ls))))))

; 別解
(defun repeat-comb1 (n ls)
  (labels ((comb-sub (n ls a b)
             (cond ((zerop n) (cons (reverse a) b))
                   ((singlep ls)
                    (cons (append (reverse a)
                                  (make-list n :initial-element (car ls)))
                          b))
                   (t
                    (comb-sub (1- n)
                              ls
                              (cons (car ls) a)
                              (comb-sub n (cdr ls) a b))))))
    (comb-sub n ls nil nil)))

重複組み合わせを求める repeat-comb も簡単です。2 番目の節で、リスト ls に要素が一つしかない場合は、その要素を n 個選びます。関数 make-list で (car ls) を n 個格納したリストを生成します。最後の節では、先頭の要素を選んだあと、それを取り除かないで ls から n - 1 個の要素を選びます。別解は局所関数 comb-sub で重複組み合わせを生成します。

●解答34

リスト : n 番目の要素で分割する

(defun split-nth (ls n)
  (values (take ls n) (drop ls n)))

; 別解
(defun split-nth1 (ls n)
  (if (zerop n)
      (values nil ls)
    (multiple-value-bind (xs ys)
        (split-nth1 (cdr ls) (1- n))
      (values (cons (car ls) xs) ys))))

split-nth は take と drop を使うと簡単です。take で先頭から n 個の要素を取り出し、drop で先頭から n 個の要素を取り除きます。そして、2 つのリストを values で返します。別解は take と drop を使わないバージョンです。

●解答35

リスト : リストの要素を偶数番目と奇数番目で分ける

(defun partition (ls)
  (labels ((odd-part (ls xs ys)
             (if (null ls)
                 (values (nreverse xs) (nreverse ys))
               (even-part (cdr ls) xs (cons (car ls) ys))))
           (even-part (ls xs ys)
             (if (null ls)
                 (values (nreverse xs) (nreverse ys))
               (odd-part (cdr ls) (cons (car ls) xs) ys))))
    (even-part ls nil nil)))

; 別解
(defun partition1 (ls)
  (do ((n 0 (1+ n))
       (ls ls (cdr ls))
       (xs nil)
       (ys nil))
      ((null ls) (values (nreverse xs) (nreverse ys)))
    (if (evenp n)
        (push (car ls) xs)
      (push (car ls) ys))))

奇数番目の要素は局所関数 odd-part で、偶数番目の要素は局所関数 even-part で取り出すと簡単です。この場合、odd-part と even-part は相互再帰になります。別解は do でプログラムしたもので、変数 n で奇数番目と偶数番目を判別しています。

●解答36

リスト : x と等しい要素の位置で分割

(defun split-find (x ls)
  (cond ((null ls) (values nil nil))
        ((eql (car ls) x) (values nil ls))
        (t (multiple-value-bind (a b)
               (split-find x (cdr ls))
             (values (cons (car ls) a) b)))))

; 別解
(defun split-find1 (x ls)
  (do ((ls ls (cdr ls))
       (xs nil))
      ((null ls) (values (nreverse xs) nil))
    (if (eql (car ls) x)
        (return (values (nreverse xs) ls))
      (push (car ls) xs))))

(defun split-find2 (x ls)
  (let ((xs (member x ls)))
    (if (null xs)
        (values ls nil)
      (values (butlast ls (length xs)) xs))))

最初の節で引数 ls が空リストの場合、values で空リストを 2 つ返します。次の節で、先頭の要素 (car ls) と x を eql で比較して、等しい場合は空リストと ls を返します。最後の節で、split-find を再帰呼び出しして、返り値を multiple-value-bind で受け取ります。そして、リスト a の先頭に ls の先頭要素 (car ls) を追加して、values で b といっしょに返します。別解は do を使った繰り返しバージョンと、member と butlast を使ったバージョンです。

●解答37

リスト : リストを x よりも大きい要素と x 以下の要素に分ける

(defun split-ge (x ls)
  (if (null ls)
      (values nil nil)
    (multiple-value-bind (a b)
        (split-ge x (cdr ls))
      (if (< (car ls) x)
          (values (cons (car ls) a) b)
        (values a (cons (car ls) b))))))

; 別解
(defun split-ge1 (x ls)
  (do ((ls ls (cdr ls))
       (xs nil)
       (ys nil))
      ((null ls) (values (nreverse xs) (nreverse ys)))
    (if (< (car ls) x)
        (push (car ls) xs)
      (push (car ls) ys))))

(defun split-ge2 (x ls)
  (let ((xs nil) (ys nil))
    (dolist (y ls (values (nreverse xs) (nreverse ys)))
      (if (< y x)
          (push y xs)
        (push y ys)))))

引数 ls が空リストの場合は空リストを 2 つ返します。else 節で split-ge を再帰呼び出しし、返り値を multiple-value-bind で受け取ります。(car ls) が x よりも小さい場合はリスト a に追加し、そうでない場合は b に追加して返します。別解は do と dolist で書き直した繰り返しバージョンです。

●解答38

リスト : 連続した同じ記号を部分リストにまとめる

; 先頭から連続している記号を取り除く
(defun drop-same-code (x ls)
  (if (or (null ls)
          (not (eql x (car ls))))
      (values nil ls)
    (multiple-value-bind (a b)
        (drop-same-code x (cdr ls))
      (values (cons x a) b))))

; 別解
(defun drop-same-code1 (x ls)
  (do ((ls ls (cdr ls))
       (xs nil))
      ((or (null ls)
           (not (eql x (car ls))))
       (values xs ls))
    (push x xs)))

; 連続した記号を部分リストにまとめる
(defun pack (ls)
  (multiple-value-bind (xs ys)
      (drop-same-code (car ls) ls)
    (if (null ys)
        (list xs)
      (cons xs (pack ys)))))

; 別解
(defun pack1 (ls)
  (labels ((pack-sub (ls xs ys)
             (cond ((null ls) (nreverse (cons xs ys)))
                   ((eql (car ls) (car xs))
                    (pack-sub (cdr ls) (cons (car ls) xs) ys))
                   (t
                    (pack-sub (cdr ls) (list (car ls)) (cons xs ys))))))
    (pack-sub (cdr ls) (list (car ls)) nil)))

(defun pack2 (ls)
  (nreverse (reduce #'(lambda (a x)
                        (if (eql (caar a) x)
                            (cons (cons x (car a)) (cdr a))
                          (cons (list x) a)))
                    (cdr ls)
                    :initial-value (list (list (car ls))))))

pack は関数 drop-same-code を定義すると簡単です。drop-same-code は先頭から連続している記号を変数 xs に格納し、それを取り除いたリストといっしょに返します。drop-same-code1 は do を使った繰り返しバージョンです。

pack は drop-same-code の返り値を multiple-value-bind で受け取り、ys が空リストであれば、(list xs) を返します。そうでなければ、ys に対して pack を再帰呼び出しし、その返り値の先頭に xs を追加します。別解は drop-same-code を使わずに do と reduce で書き直したものです。

●解答39

リスト : 連続している数列を (s . e) で表す

(defun pack-num-list (ls)
  (labels ((push-num (s e a)
             (if (= s e) (cons s a) (cons (cons s e) a)))
           (iter (ls s e a)
             (cond ((null ls) (nreverse (push-num s e a)))
                   ((= (car ls) (1+ e))
                    (iter (cdr ls) s (car ls) a))
                   (t
                    (iter (cdr ls) (car ls) (car ls) (push-num s e a))))))
    (iter (cdr ls) (car ls) (car ls) nil)))

; 別解
(defun pack-num-list1 (ls)
  (let ((s (car ls)) (e (car ls)) (a nil))
    (dolist (x (cdr ls))
      (cond ((= x (1+ e))
             (setf e x))
            (t
             (push (if (= s e) s (cons s e)) a)
             (setf s x e x))))
    (push (if (= s e) s (cons s e)) a)
    (nreverse a)))

局所関数 iter の引数 s が start を、引数 e が終点を表します。引数 a は累積変数として使います。最初の節で ls が空リストの場合は、push-num で a に (s . e) を追加して、その結果を nreverse で反転して返します。

次の節で、(car ls) が e + 1 と等しい場合は連続した数字です。iter を再帰呼び出しするとき、引数 e に (car ls) を渡します。そうでなければ、引数 s, e に (car ls) を渡して、push-num で引数 a に (s . e) を追加して iter を再帰呼び出しします。別解は dolist を使った繰り返しバージョンです。

●解答40

リスト : (s . e) を数列に戻す

(defun expand-num-list (ls)
  (cond ((null ls) nil)
        ((consp (car ls))
         (append (iota (caar ls) (cdar ls))
                 (expand-num-list (cdr ls))))
        (t
         (cons (car ls) (expand-num-list (cdr ls))))))

; 別解
(defun expand-number (s e a)
  (if (< e s)
      a
    (expand-number (+ s 1) e (cons s a))))

(defun expand-num-list1 (ls)
  (nreverse (reduce #'(lambda (a x)
                        (if (consp x)
                            (expand-number (car x) (cdr x) a)
                          (cons x a)))
                    ls
                    :initial-value nil)))

expand-num-list は iota を使うと簡単です。最初の節が再帰の停止条件です。次の節で、(s . e) を iota で数列に変換します。expand-num-list を再帰呼び出しして残りのリスト (cdr ls) を数列に戻し、そのリストと iota で変換したリストを append で連結します。最後の節はリストの要素が数値の場合で、残りのリスト (cdr ls) を数列に変換し、そのリストの先頭に (car ls) を追加します。別解は reduce を使ったバージョンです。

●解答41

リスト : ランレングス符号化

(defun encode (ls)
  (mapcar #'(lambda (xs) (cons (car xs) (length xs)))
          (pack ls)))

; 別解
(defun encode1 (ls)
  (do ((n 1)
       (a nil)
       (c (car ls))
       (ls (cdr ls) (cdr ls)))
      ((null ls) (nreverse (cons (cons c n) a)))
    (cond ((eql (car ls) c)
           (incf n))
          (t
           (push (cons c n) a)
           (setf c (car ls) n 1)))))

(defun encode2 (ls)
  (labels ((encode-sub (ls c n a)
             (cond ((null ls) (nreverse (cons (cons c n) a)))
                   ((eql (car ls) c)
                    (encode-sub (cdr ls) c (1+ n) a))
                   (t
                    (encode-sub (cdr ls) (car ls) 1 (cons (cons c n) a))))))
    (encode-sub (cdr ls) (car ls) 1 nil)))

encode は pack を使うと簡単です。pack の返り値を mapcar で (code . n) に変換するだけです。別解の encode1 は pack を使わずに do による繰り返しで連続した記号の数をカウントしています。encode2 は末尾再帰バージョンです。

●解答42

リスト : ランレングス復号

(defun decode (ls)
  (flatmap #'(lambda (xs)
               (make-list (cdr xs) :initial-element (car xs)))
           ls))

; 別解
(defun decode1 (ls)
  (if (null ls)
      nil
    (append (make-list (cdar ls) :initial-element (caar ls))
            (decode (cdr ls)))))

ランレングスの復号は関数 flatmap と make-list を使うと簡単です。make-list で (code . n) をリストに変換し、flatmap でそれを平坦化するだけです。別解は単純な再帰呼び出してプログラムしたものです。

●解答43

リスト : any と every

(defun any (pred ls)
  (cond ((null ls) nil)
        ((funcall pred (car ls)) t)
        (t (any pred (cdr ls)))))

(defun my-every (pred ls)
  (cond ((null ls) t)
        ((funcall pred (car ls))
         (my-every pred (cdr ls)))
        (t nil)))

any と my-every は簡単です。(funcall pred (car ls)) が真を返す場合、any は t を返します。逆に偽を返す場合、my-every は nil を返します。それ以外の場合は再帰呼び出しして次の要素をチェックします。引数のリストが空リストになった場合、any は nil を返し、my-every は t を返します。

●解答44

リスト : maplist

(defun my-maplist (fn ls)
  (if (null ls)
      nil
    (cons (funcall fn ls) (my-maplist fn (cdr ls)))))

my-maplist は簡単です。関数 fn に引数のリスト ls をそのまま渡すだけです。my-maplist を再帰呼び出しするときは、先頭の要素を取り除いたリスト (cdr ls) を渡します。my-maplist を使うと mapcar は次のように定義することができます。

リスト : mapcar の定義

(defun my-mapcar (fn ls)
  (my-maplist #'(lambda (x) (funcall fn (car x))) ls))

●解答45

リスト : リスト操作の一般化

(defun for-each-list (fn comb term ls)
  (if (null ls)
      term
    (funcall comb
             (funcall fn (car ls))
             (for-each-list fn comb term (cdr ls)))))

関数 for-each-list の引数 fn はリストの要素に適用する関数、comb は fn の返り値と for-each-list の返り値を結合する関数、term はリストの終端で返す値です。プログラムは簡単で、引数のリストが空リストならば term を返します。そうでなければ、リストの要素 (car ls) に関数 fn を適用し、その返り値と for-each-list の返り値を関数 comb で結合します。

なお、次のように一般化することもできます。

リスト : リスト操作の一般化 (2)

(defun for-each-list1 (fn comb term ls)
  (if (null ls)
      term
    (funcall comb
             (funcall fn ls)
             (for-each-list1 fn comb term (cdr ls)))))

関数 fn に渡すのはリストの要素 (car ls) ではなく、リスト ls を渡しています。

●解答46

リスト : マッピング、フィルター、畳み込み

(defun my-mapcar (fn ls)
  (for-each-list fn #'cons nil ls))

(defun my-filter (pred ls)
  (for-each-list #'(lambda (x) (if (funcall pred x) (list x) nil))
                 #'append
                 nil
                 ls))

(defun fold-right (fn a ls)
  (for-each-list #'identity
                 #'(lambda (x y) (funcall fn x y))
                 a
                 ls))

my-mapcar は comb に cons を、term に ( ) を渡せば実現できます。filter はリストの要素 x に関数 fn を適用し、真を返す場合は (list x) を返し、偽の場合は ( ) を返します。それを append で連結すると、( ) はリストの要素に含まれないので、フィルターとして動作します。fold-right も簡単です。identity でリストの要素をそのまま返し、要素を連結する関数の中で関数 fn を呼び出します。

なお、リスト操作の一般化 (2) で示した for-each-list1 を使うと、mapcar, maplist, filter, fold-right は次のようになります。

リスト : マッピング、フィルター、畳み込み (2)

(defun my-mapcar1 (fn ls)
  (for-each-list1 #'(lambda (x) (funcall fn (car x)))
                  #'cons
                  nil
                  ls))

(defun my-maplist1 (fn ls)
  (for-each-list1 #'(lambda (x) (funcall fn x)) #'cons nil ls))

(defun filter1 (pred ls)
  (for-each-list1 #'car
                  #'(lambda (x y)
                      (if (funcall pred x) (cons x y) y))
                  nil
                  ls))

(defun fold-right1 (fn a ls)
  (for-each-list1 #'car #'(lambda (x y) (funcall fn x y)) a ls))

●解答47

リスト : 小町分数

(defun calc-1 (a b c)
  (/ a (+ (* b 10) c)))
(defun calc-2 (ls)
  (apply #'+ (mapcar #'(lambda (xs) (apply #'calc-1 xs)) (group ls 3))))
(defun print-1 (a b c)
  (format t "~D/~D~D" a b c))
(defun print-2 (ls n)
  (apply #'print-1 (car ls))
  (format t " + ")
  (apply #'print-1 (cadr ls))
  (format t " + ")
  (apply #'print-1 (caddr ls))
  (format t " = ~A~%" n))

(defun solve-47 ()
  (dolist (ls (permutation 9 (iota 1 9)))
    (let ((n (calc-2 ls)))
      (when (and (integerp (/ n))
                 (< (elt ls 0) (elt ls 3) (elt ls 6)))
        (print-2 (group ls 3) n)))))

単純な生成検定法です。重複解を排除するため、A < D < G の条件を付けています。また、順列を生成するとき、このチェックを入れることで枝刈りと同じ効果を得ることができます。興味のある方は試してみてください。実行結果は次のようになります。

> (solve-47)
1/24 + 3/56 + 7/98 = 1/6
1/26 + 5/39 + 7/84 = 1/4
1/32 + 5/96 + 7/84 = 1/6
1/38 + 2/95 + 4/76 = 1/10
1/48 + 5/32 + 7/96 = 1/4
1/56 + 3/72 + 9/84 = 1/6
1/96 + 5/32 + 7/84 = 1/4
1/96 + 5/48 + 7/32 = 1/3
2/18 + 5/63 + 7/49 = 1/3
2/19 + 4/57 + 6/38 = 1/3
3/27 + 6/54 + 9/81 = 1/3
3/48 + 5/16 + 9/72 = 1/2
3/54 + 6/72 + 9/81 = 1/4
5/34 + 7/68 + 9/12 = 1

●解答48

リスト : 魔方陣

(defvar *line* '((0 1 2) (3 4 5) (6 7 8) (0 3 6)
                 (1 4 7) (2 5 8) (0 4 8) (2 4 6)))

(defun calc-line (ls a b c)
  (+ (elt ls a) (elt ls b) (elt ls c)))

(defun check (ls)
  (let ((n (apply #'calc-line ls (car *line*))))
    (every #'(lambda (xs) (= n (apply #'calc-line ls xs)))
           (cdr *line*))))

(defun solve-48 ()
  (dolist (ls (permutation 9 (iota 1 9)))
    (if (check ls) (print ls))))

単純な生成検定法です。実行結果は次のようになります。

> (solve-48)

(2 7 6 9 5 1 4 3 8)
(2 9 4 7 5 3 6 1 8)
(4 3 8 9 5 1 2 7 6)
(4 9 2 3 5 7 8 1 6)
(6 1 8 7 5 3 2 9 4)
(6 7 2 1 5 9 8 3 4)
(8 1 6 3 5 7 4 9 2)
(8 3 4 1 5 9 6 7 2)

解は 8 通り出力されましたが、重複解を取り除くと解は一通りしかありません。重複解のチェックは面倒だと思われる方もいるでしょう。ところが、下図のように四隅の大小関係を利用すると簡単です。


      図 : 対称解のチェック

魔方陣の場合、回転解が 4 種類あって、鏡像解が 2 種類あります。四隅の大小関係をチェックすることで、これらの対称解を排除することができます。また、順列を生成するとき、重複解のチェックを入れると枝刈りと同じ効果を得ることができます。興味のある方は試してみてください。

●解答49

リスト : 小町覆面算

(defun calc-word (ls a b c d e)
  (+ (* (elt ls a) 10000)
     (* (elt ls b) 1000)
     (* (elt ls c) 100)
     (* (elt ls d) 10)
     (elt ls e)))

(defun solve-49 ()
  (dolist (ls (permutation 9 (iota 1 9)))
    (let ((wrong (calc-word ls 0 1 2 3 4))
          (right (calc-word ls 1 5 4 6 7))
          (m (elt ls 8)))
      (if (= (* wrong m) right)
          (format t "~D * ~D = ~D~%" wrong m right)))))

単純な生成検定法です。実行結果は次のようになります。

> (solve-49)
16958 * 4 = 67832

●解答50

素数を求める基本的な考え方は簡単です。最初に、2 から n までの整数列を生成します。先頭の 2 は素数なので、この整数列から 2 で割り切れる整数を取り除き除きます。2 で割り切れる整数が取り除かれたので、残った要素の先頭が素数になります。先頭要素は 3 になるので、今度は 3 で割り切れる整数を取り除けばいいのです。このように、素数を見つけたらそれで割り切れる整数を取り除いていくアルゴリズムを「エラトステネスの篩 (ふるい) 」といいます。

プログラムは次のようになります。

リスト : 素数 (エラトステネスの篩)

(defun sieve (n)
  (do ((ls (iota 2 n))
       (a nil))
      ((null ls) (nreverse a))
    (push (car ls) a)
    (setf ls (remove-if #'(lambda (x) (zerop (mod x (car ls))))
                        (cdr ls)))))

sieve の処理は do ループで行います。iota で 2 から n までの整数列を生成し、それを変数 ls にセットします。繰り返しの中で、ls の先頭要素で割り切れる要素を remove-if で取り除きます。このとき、累積変数 a に (car ls) を追加します。ls が空リストになったら、nreverse でリスト a を反転して返します。

●別解 (2012/10/08)

関数 sieve には無駄な処理があります。リストの先頭要素 x が √n よりも大きい場合、リストには素数しか残っていません。つまり、ふるいにかけるのは x <= √n まででいいのです。これをプログラムすると次のようになります。

リスト :  別解

(defun reverse-append (xs ys)
  (if (null xs)
      ys
    (reverse-append (cdr xs) (cons (car xs) ys))))

(defun sieve1 (n)
  (do ((ls (iota 2 n))
       (a nil))
      ((< n (* (car ls) (car ls)))
       (reverse-append a ls))
    (push (car ls) a)
    (setf ls (remove-if #'(lambda (x) (zerop (mod x (car ls))))
                        (cdr ls)))))

do ループの中で、リストの先頭要素 x が x * x > n ならば、累積変数 a とリスト xs を関数 reverse-append で連結して返します。これで sieve よりも速く素数を求めることができます。

remove-if のかわりにリストを破壊的に修正する関数 delete-if を使うと、実行速度はもうすこし速くなります。次のリストを見てください。

リスト : 別解 (2)

(defun sieve2 (n)
  (do ((ls (iota 2 n))
       (a nil))
      ((< n (* (car ls) (car ls)))
       (reverse-append a ls))
    (push (car ls) a)
    (setf ls (delete-if #'(lambda (x) (zerop (mod x (car ls))))
                        (cdr ls)))))

関数 sieve2 は remove-if のかわりに delete-if を呼び出すだけです。

ところで、「エラトステネスの篩」はベクタを使ってプログラムしたほうが高速になります。次のリストを見てください。

リスト : ベクタ版

(defun sieve3 (n)
  (let ((p (make-array (1+ (floor n 2)) :initial-element t))
        (a (list 2)))
    (do ((i 3 (+ i 2)) (j 1 (1+ j)))
        ((< n (* i i))
         ;
         (do ((i i (+ i 2)) (j j (1+ j)))
             ((< n i) (nreverse a))
           (when (aref p j)
             (push i a))))
      (when (aref p j)
        (push i a)
        (do ((k (+ j i) (+ k i)))
            ((<= (length p) k))
          (setf (aref p k) nil))))))

真偽値を格納するベクタ p で奇数列 (1, 3, 5, 7, ... ) を表します。t で素数を表し、素数でない場合は nil に書き換えます。ベクタ p は t で初期化されるので、最初はすべての数が素数ということになります。

プログラムでは、奇数を変数 i で、それに対応するベクタ p の添字を変数 j で表します。変数 i は 3, 5, 7, 9, ... に、それに対応する変数 j は 1, 2, 3, 4, ... になります。この場合、i の倍数に対応する j の値は j + i, j + i * 2, j + i * 3, ... になります。たとえば、3, 5, 7 の倍数は次のようになります。

i |  3  5  7  9 11 13 15 17 19 21 23 25
j |  1  2  3  4  5  6  7  8  9 10 11 12
--+-------------------------------------
3 |  O        0        O        0
5 |     0              0              0
7 |        0                    0

プログラムは簡単です。最初の do ループで i が √n 以下の処理を行います。この中で素数 i の倍数を削除します。そのあと、ベクタ p に残された素数をリスト a に格納して返します。

それでは実行結果を示します。

        実行結果
---------------------------
(sieve1 5000000) : 10.61 秒
(sieve2 5000000) :  6.35 秒
(sieve3 5000000) :  0.23 秒

実行環境 : Windows 7, Core i7-2670QM 2.20GHz, SBCL 1.0.55

ベクタを使った sieve3 が一番速くなりました。


Copyright (C) 2010 Makoto Hiroi
All rights reserved.

[ PrevPage | Common Lisp | NextPage ]