●問題51
リストを平坦化する関数 flatten ls を定義してください。
> (flatten '(a (b (c d . e) f) g)) (a b c d e f g)
●問題52
リストを木とみなして、2 つの木を比較する関数 same-fringe-p を定義してください。同じ葉を同じ並びで持つ場合、same-fringe-p は t を返します。
> (same-fringe-p '(1 2 (3) 4) '(1 2 (3 4)) t > (same-fringe-p '(1 2 (3) 4) '(1 2 (4) 3) nil
最初の例の場合、木の構造は違いますが、要素はどちらの木も 1, 2, 3, 4 の順番で並んでいるので、same-fringe-p は t を返します。次の例では、木の構造は同じですが、 3 と 4 の順番が逆になっています。この場合、same-fringe-p は nil を返します。
●問題53
リストを挿入ソートする関数 insert-sort pred ls を定義してください。
> (insert-sort #'< '(5 6 4 7 3 8 2 9 1)) (1 2 3 4 5 6 7 8 9)
●問題54
リストをクイックソートする関数 quick-sort pred ls を定義してください。
> (quick-sort #'< '(5 6 4 7 3 8 2 9 1)) (1 2 3 4 5 6 7 8 9)
●問題55
リスト ls のべき集合を求める関数 power-set ls を定義してください。たとえばリスト (a b c) のべき集合は nil, (a), (b), (c), (a b), (a c), (b c), (a b c) になります。
> (power-set '(a b c)) (nil (c) (b) (b c) (a) (a c) (a b) (a b c))
●問題56
ナイトはチェスの駒のひとつで将棋の桂馬の動きを前後左右にとることができます。次の図を見てください。
「騎士の巡歴 (Knight's Tour) 」は、ナイトを動かして N 行 M 列の盤面のどのマスにもちょうど一回ずつ訪れるような経路を求める問題です。ちなみに、3 行 3 列、4 行 4 列の盤面には解がありませんが、5 行 5 列、5 行 6 列の盤面には解があります。たとえば、左上隅からスタートしたとすると、5 行 5 列盤の解は全部で 304 通りあります。5 行 6 列盤における解の総数を求めてください。
●問題57
騎士の巡歴は「どのマスにもちょうど一回ずつ訪れたのち最初のマスに戻ってくること」を条件にする場合があります。これを「騎士の周遊」と呼びます。騎士の周遊の場合、5 行 5 列盤には解はありませんが、5 行 6 列盤には解があります。解の総数を求めてください。
●問題58
「ラテン方陣」は数独の枠の条件を無くした方陣です。ラテン方陣の定義を 参考文献 [1] より引用します。
『ラテン方陣を一般的にいうなら、n 行 n 列の正方形の枡に n 種類の記号を n 個ずつ配列して、各行各列に記号の重複のないものを n 次のラテン方陣というのです。』
このラテン方陣をパズルに応用したものが数独というわけです。
簡単な例を示しましょう。3 次のラテン方陣は次に示す 12 通りになります。
0 1 2 0 1 2 0 2 1 0 2 1 1 0 2 1 0 2
1 2 0 2 0 1 1 0 2 2 1 0 0 2 1 2 1 0
2 0 1 1 2 0 2 1 0 1 0 2 2 1 0 0 2 1
標準形
1 2 0 1 2 0 2 0 1 2 0 1 2 1 0 2 1 0
0 1 2 2 0 1 0 1 2 1 2 0 0 2 1 1 0 2
2 0 1 0 1 2 1 2 0 0 1 2 1 0 2 0 2 1
図 : 3 次のラテン方陣
この中で、最初の行と列の要素を昇順に並べたものを「標準形」といいます。3 次のラテン方陣の場合、標準形は 1 種類しかありません。ラテン方陣は任意の行を交換する、または任意の列を交換してもラテン方陣になります。3 次のラテン方陣の場合、標準形から行または列を交換することで、残りの 11 種類のラテン方陣を生成することができます。
4, 5, 6, 7 次の標準形ラテン方陣の総数を求めてください。
[1] 大村平, 『数理パズルのはなし』, 日科技連出版社, 1998
●問題59
下図に示す 6 行 6 列盤の数独において、数独の解となる盤面の総数を求めてください。
●問題60
9 行 9 列盤の数独を解くプログラムを作成してください。
●解答51
リスト : リストの平坦化
(defun flatten (ls)
(cond ((null ls) nil)
((atom ls) (list ls))
(t (append (flatten (car ls)) (flatten (cdr ls))))))
; 別解
(defun flatten1 (ls)
(labels ((iter (ls a)
(cond ((null ls) a)
((atom ls) (cons ls a))
(t (iter (car ls)
(iter (cdr ls) a))))))
(iter ls nil)))
flatten は簡単です。ls が空リストの場合は nil を、(atom ls) が真の場合は (list ls) を返します。それ以外の場合は (car ls) と (car cdr) を flatten で平坦化し、それらを append で連結するだけです。別解は append を使わずに、局所関数 iter の引数 a に要素を格納します。flatten1 は末尾からリストをたどることに注意してください。
●解答52
リスト : ツリーマッチング (defun same-fringe-p (xs ys) (equal (flatten xs) (flatten ys)))
ツリーマッチングは flatten を使うと簡単です。xs と ys を flatten で平坦化し、それを equal で比較するだけです。このほかに、遅延ストリームを使った方法もあります。興味のある方は拙作のページ 遅延ストリーム (2) をお読みください。
●解答53
挿入ソートの考え方はとても簡単です。ソート済みのリストに新しいデータを挿入していくことでソートを行います。たとえば、リスト (2 4 6) に 5 を挿入する場合、リストの要素 n と 5 を順番に比較して、5 < n を満たす位置に 5 を挿入すればいいわけです。この場合は、4 と 6 の間に 5 を挿入すればいいですね。
ソートするリストは、cdr で分解していくと空リストになります。これをソート済みのリストと考えて、ここにデータを挿入していきます。プログラムは次のようになります。
リスト : 挿入ソート
(defun insert-sort (pred ls)
(labels ((insert (x xs)
(cond ((null xs) (list x))
((funcall pred x (car xs))
(cons x xs))
(t (cons (car xs) (insert x (cdr xs))))))
(sort (xs)
(if (null xs)
nil
(insert (car xs) (sort (cdr xs))))))
(sort ls)))
; 別解
(defun insert-sort1 (pred ls)
(labels ((insert (x xs)
(do ((p xs (cdr p))
(q (cdr xs) (cdr q)))
((null q) (setf (cdr p) (list x)))
(when (funcall pred x (car q))
(setf (cdr p) (cons x q))
(return))))
(sort (xs)
(let ((head (list nil))) ; ヘッダー
(dolist (x xs (cdr head))
(insert x head)))))
(sort ls)))
リストにデータをひとつ挿入する局所関数が insert です。再帰呼び出しでリストをたどり、データ x を挿入する位置を探します。比較関数 pred の返り値が真であれば、その位置にデータを挿入します。局所関数 sort は引数のリストを再帰呼び出しで分解します。空リストになると再帰呼び出しが停止します。そして、car で取り出した要素を insert でソート済みのリストに挿入します。別解は再帰呼び出しではなく繰り返しでプログラムしたバージョンです。
●解答54
クイックソートはある値を基準にして、要素をそれより大きいものと小さいものの 2 つに分割していくことでソートを行います。基準になる値のことを「枢軸 (pivot) 」といいます。枢軸は要素の中から適当な値を選んでいいのですが、リストの場合は任意の箇所を簡単に選ぶことができません。この場合、いちばん簡単に求めることができる先頭の要素を枢軸とします。
リストを 2 つに分けたら、それらを同様にソートします。これは、再帰を使えば簡単に実現できます。その結果を枢軸を挟んで結合します。これを図に表すと次のようになります。
5 3 7 6 9 8 1 2 4
5 を枢軸に分割
(3 1 2 4) 5 (7 6 9 8)
3を枢軸に分割 7を枢軸に分割
(1 2) 3 (4) | 5 | (6) 7 (9 8)
・・・分割を繰り返していく・・・
図 : クイックソート
このようにリストを分割していくと、最後は空リストになります。ここが再帰の停止条件になります。あとは分割したリストを append で結合すればいいわけです。プログラムは次のようになります。
リスト : リストのクイックソート
; リストの分割
(defun partition (pred p ls)
(let ((xs nil) (ys nil))
(dolist (x ls (values xs ys))
(if (funcall pred x p)
(push x xs)
(push x ys)))))
; クイックソート
(defun quick-sort (pred ls)
(if (null (cdr ls))
ls
(multiple-value-bind (xs ys)
(partition pred (car ls) (cdr ls))
(append (quick-sort pred xs)
(cons (car ls) (quick-sort pred ys))))))
; 別解
(defun quick-sort1 (pred ls)
(unless (null ls)
(let ((p (car ls))
(xs nil) (ys nil))
(dolist (x (cdr ls))
(if (funcall pred x p) (push x xs) (push x ys)))
(append (quick-sort1 pred xs)
(cons p (quick-sort1 pred ys))))))
リストの分割は関数 partition で行います。引数 p が枢軸になります。dolist でリストから要素を取り出し、関数 pred で枢軸と比較します。pred の返り値が真であれば、要素 x を xs のリストに格納し、そうでなければ ys のリストに格納します。これで枢軸を基準にデータを 2 つのリストに分けることができます。
あとは、関数 quick-sort で partition を呼び出し、返り値を xs と ys で受け取ります。そして、quick-sort を再帰呼び出しして、その結果を append で結合します。別解は partition を使わないバージョンです。
クイックソートの実行時間は、データ数を N とすると平均して N * log2 N に比例します。ところが、枢軸の選び方によっては、最悪で N の 2 乗に比例するまで劣化します。クイックソートはリストには不向きのアルゴリズムといえます。
●解答55
リスト : べき集合
(defun power-set (ls)
(if (null ls)
(list nil)
(append (power-set (cdr ls))
(mapcar #'(lambda (xs) (cons (car ls) xs))
(power-set (cdr ls))))))
; 別解
(defun power-set1 (func ls)
(labels ((power-sub (ls a)
(if (null ls)
(funcall func (reverse a))
(progn
(power-sub (cdr ls) (cons (car ls) a))
(power-sub (cdr ls) a)))))
(power-sub ls nil)))
べき集合を求める関数 power-set は簡単です。ls が空リストの場合は nil を格納したリストを返します。そうでなければ power-set を再帰呼び出しして (cdr ls) のべき集合を求め、その集合に先頭要素 (car ls) を追加します。そして、その集合と (cdr ls) のべき集合を append で連結します。
別解の power-set1 は高階関数バージョンです。リストの長さを N とすると、べき集合の要素数は 2 ^ N になります。N が大きくなると、べき集合をリストに格納して返すことは困難になります。その場合は高階関数を使うとよいでしょう。
●解答56
それではプログラムを作りましょう。盤面は 2 次元配列で表します。この場合、騎士の移動手順は盤面に記録したほうが簡単です。騎士が訪れていないマスを 0 とし、騎士の移動手順を 1 から始めれば、移動できるマスの判定を簡単に行うことができます。また、経路の出力も盤面を表示した方が直感的でわかりやすいかもしれません。
次は盤面の構成を考えましょう。単純な 5 行 6 列の 2 次元配列にすると、騎士が盤面から飛び出さないようにするため座標の範囲チェックが必要になります。このような場合、盤面の外側に壁を設定するとプログラムが簡単になります。下図を見てください。
W W W W W W W W W W
W W W W W W W W W W
W W K 0 0 0 0 0 W W
W W 0 0 0 0 0 0 W W
W W 0 0 0 0 0 0 W W
W W 0 0 0 0 0 0 W W
W W 0 0 0 0 0 0 W W
W W W W W W W W W W
W W W W W W W W W W
K : ナイト, W : 壁
図：盤面の構成
騎士は最大で 2 マス移動するので、壁の厚さも 2 マス用意します。したがって、盤面を表す配列は 9 行 10 列の大きさになります。壁に 0 以外の値を設定しておけば、騎士が盤面から飛び出して壁の位置に移動しようとしても、盤面の値が 0 ではないので実際に移動することはできません。これで騎士を移動したときの範囲チェックを省略することができます。
プログラムは次のようになります。
リスト : 騎士の巡歴
; 盤面
(defvar *board* (make-array '(10 9) :initial-element nil))
; 方向
(defvar *dir* '((1 . -2) (2 . -1) (2 . 1) (1 . 2)
(-1 . 2) (-2 . 1) (-2 . -1) (-1 . -2)))
; 盤面の初期化
(defun initialize-board ()
(dotimes (y 5)
(dotimes (x 6)
(setf (aref *board* (+ x 2) (+ y 2)) 0))))
; 盤面の表示
(defun print-board ()
(dotimes (y 5 (terpri))
(dotimes (x 6 (terpri))
(format t "~3D" (aref *board* (+ x 2) (+ y 2))))))
; 解法
(defun knight-tour (func)
(labels ((solve (n x y)
(setf (aref *board* x y) n)
(if (= n 30)
; 解を発見
(funcall func)
(dolist (p *dir*)
(let ((x1 (+ x (car p)))
(y1 (+ y (cdr p))))
(when (eql (aref *board* x1 y1) 0)
(solve (1+ n) x1 y1)))))
; 元に戻す
(setf (aref *board* x y) 0)))
(initialize-board)
(solve 1 2 2)))
盤面を表す配列は変数 *board* にセットします。壁は nil で表します。変数 *dir* は x 方向の変位と y 方向の変位を表すリストです。現在の座標にこの値を加えることで、次の座標を決定します。*board* の初期化は関数 initialize-board で行います。
関数 knight-tour の局所関数 solve は引数として手数 n と騎士の座標 x, y を受け取ります。最初に、盤面の x, y の位置に n を書き込みます。そして、n が 30 であればすべてのマスを訪れたので関数 func を呼び出します。そうでなければ、dolist で x, y 方向の変位を取り出して、騎士の移動先 x1, y1 を求めます。盤面の x1, y1 の位置が 0 であれば、solve を再帰呼び出しして騎士を移動します。
実行結果は次のようになりました。
* (let ((c 0)) (knight-tour #'(lambda () (incf c))) c)) 4542
実行時間は Windows XP, celeron 1.40 GHz, SBCL ver 1.0.37 で約 62 秒でした。解の一例を下図に示します。
1 26 9 18 3 14
24 19 2 15 10 17
27 8 25 22 13 4
20 23 6 29 16 11
7 28 21 12 5 30
図 : 騎士の巡歴の解 (一例)
●解答57
「騎士の周遊」は「騎士の巡歴」のプログラムに、スタート地点に戻ることができるかチェックする処理を追加するだけです。プログラムは次のようになります。
リスト : 騎士の周遊
; start に戻れるか
(defun check (x y)
(dolist (p *dir*)
(if (eql (aref *board* (+ x (car p)) (+ y (cdr p))) 1)
(return t))))
(defun closed-knight-tour (func)
(labels ((solve (n x y)
(setf (aref *board* x y) n)
(if (= n 30)
(if (check x y)
; 解を発見
(funcall func))
(dolist (p *dir*)
(let ((x1 (+ x (car p)))
(y1 (+ y (cdr p))))
(when (eql (aref *board* x1 y1) 0)
(solve (1+ n) x1 y1)))))
; 元に戻す
(setf (aref *board* x y) 0)))
(initialize-board)
(solve 1 2 2)))
手数 n が 30 になったら関数 check を呼び出してスタート地点に戻ることができるかチェックします。check の処理は簡単で、x, y の地点から騎士を動かして、盤面の値が 1 であればスタート地点に戻ることができます。
実行結果と解の一例を下図に示します。
* (let ((c 0)) (closed-knight-tour #'(lambda () (incf c))) c) 16
1 18 11 22 3 16
10 27 2 17 12 23
19 30 21 6 15 4
26 9 28 13 24 7
29 20 25 8 5 14
図 : 騎士の周遊の解 (一例)
●解答58
プログラムは拙作のページ Scheme Programming ちょっと寄り道「ラテン方陣」 のプログラムを Common Lisp で書き直したものです。詳しい説明は拙作のページ パズルの解法 [4] [5] をお読みください。
リスト : 標準形ラテン方陣の総数を求める
; ビット操作用マクロ
(defmacro dobit ((var num &optional result) &body body)
(let ((temp-num (gensym "DOBIT")))
`(do ((,temp-num ,num))
((not (plusp ,temp-num)) ,result)
(let ((,var (logand (- ,temp-num) ,temp-num)))
,@body
(setq ,temp-num (logxor ,temp-num ,var))))))
;;; 大域変数
(defvar *board* nil)
(defvar *xflag* nil)
(defvar *yflag* nil)
;;; 操作関数
; 可能性のある数字を求める (数字はビットで管理する)
(defun get-numbers (x y)
(logand (aref *xflag* x) (aref *yflag* y)))
; フラグの反転
(defun rev-flag (x y n)
(setf (aref *xflag* x)
(logxor (aref *xflag* x) n))
(setf (aref *yflag* y)
(logxor (aref *yflag* y) n)))
; 数字のセット
(defun set-number (x y n)
(setf (aref *board* x y) n)
(rev-flag x y n))
; 数字を取り消す
(defun del-number (x y n)
(setf (aref *board* x y) 0)
(rev-flag x y n))
;;; 盤面の表示
(defun print-board (board)
(let ((size (length *xflag*)))
(dotimes (y size (terpri))
(dotimes (x size (terpri))
(format t "~D " (1+ (logcount (- (aref board x y)))))))))
;;; 初期化
(defun initialize-latina (size)
(setf *board* (make-array (list size size) :initial-element 0)
*xflag* (make-array size :initial-element (1- (expt 2 size)))
*yflag* (make-array size :initial-element (1- (expt 2 size))))
; 標準形を作る
(dotimes (x size)
(set-number x 0 (ash 1 x))
(set-number 0 x (ash 1 x))))
;;; 標準形のラテン方陣を求める
(defun latina (func size)
(labels ((solve (x y)
(cond ((= y size)
(funcall func *board*))
((= x size)
(solve 0 (1+ y)))
((zerop (aref *board* x y))
(dobit (z (get-numbers x y))
(set-number x y z)
(solve (1+ x) y)
(del-number x y z)))
(t (solve (1+ x) y)))))
(initialize-latina size)
(solve 0 0)))
標準形ラテン方陣の総数は次のようになります。
I4 = 4 I5 = 56 I6 = 9408 I7 = 16942080
7 次ラテン方陣の実行時間は Windows XP, celeron 1.40 GHz, SBCL ver 1.0.37 で約 210 秒でした。高次の標準形ラテン方陣の総数は、簡単に求めることができない非常にハードな問題だと思います。
●解答59
解の総数を求める場合、単純な方法では 6 * 6 の数独でも大変です。そこでラテン方陣のような標準形を考えることにします。数独の場合、数字 N と数字 M を交換しても数独の条件を満たすので、数字の配置を下図のように限定することにします。
1 2 3 4 5 6 4 5 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 図 : 数字の配置
一番上の行で数字を交換することで 6! = 720 通り、右上のグループの残り 3 つの数字を交換することで 6 通りの解が生成されます。したがって、上図の解の総数を I とすると、解の総数は I * 720 * 6 になります。
プログラムは次のようになります。
リスト : 数独 (6 行 6 列盤) の解の総数を求める
;;; 大域変数
(defvar *board* nil)
(defvar *xflag* nil)
(defvar *yflag* nil)
(defvar *gflag* nil)
;;; 操作関数
; グループ番号を求める
(defun get-group (x y)
(+ (* 2 (floor y 2)) (floor x 3)))
; 可能性のある数字を求める (数字はビットで管理する)
(defun get-numbers (x y)
(logand (aref *xflag* x)
(aref *yflag* y)
(aref *gflag* (get-group x y))))
; フラグの反転
(defun rev-flag (x y n)
(setf (aref *xflag* x)
(logxor (aref *xflag* x) n))
(setf (aref *yflag* y)
(logxor (aref *yflag* y) n))
(setf (aref *gflag* (get-group x y))
(logxor (aref *gflag* (get-group x y)) n)))
; 数字のセット
(defun set-number (x y n)
(setf (aref *board* x y) n)
(rev-flag x y n))
; 数字を取り消す
(defun del-number (x y n)
(setf (aref *board* x y) 0)
(rev-flag x y n))
;;; 盤面の表示
(defun print-board (board)
(let ((size (length *xflag*)))
(dotimes (y size (terpri))
(dotimes (x size (terpri))
(format t "~D " (1+ (logcount (- (aref board x y)))))))))
;;; 初期化
(defun initialize-number-place (size)
(setf *board* (make-array (list size size) :initial-element 0)
*xflag* (make-array size :initial-element (1- (expt 2 size)))
*yflag* (make-array size :initial-element (1- (expt 2 size)))
*gflag* (make-array size :initial-element (1- (expt 2 size))))
(dotimes (x size)
(set-number x 0 (ash 1 x)))
(set-number 0 1 (ash 1 3))
(set-number 1 1 (ash 1 4))
(set-number 2 1 (ash 1 5)))
;;; 6 * 6 の解の総数を求める
(defun number-place6 (func)
(labels ((solve (x y)
(cond ((= y 6)
(funcall func *board*))
((= x 6)
(solve 0 (1+ y)))
((zerop (aref *board* x y))
(dobit (z (get-numbers x y))
(set-number x y z)
(solve (1+ x) y)
(del-number x y z)))
(t (solve (1+ x) y)))))
(initialize-number-place 6)
(solve 0 0)))
実行結果は次のようになりました。
* (let ((c 0)) (number-place6 #'(lambda (x) (incf c))) c) 6528
解の総数は 6528 * 720 * 6 = 28200960 になります。
●解答60
単純なバックトラック法だけで解く場合、プログラムは次のようになります。
リスト : 数独の解法
;;; 大域変数
(defvar *size* 9)
(defvar *board* nil)
(defvar *xflag* nil)
(defvar *yflag* nil)
(defvar *gflag* nil)
;;; 操作関数
; グループ番号の取得
(defun get-group (x y)
(+ (* 3 (floor y 3)) (floor x 3)))
; 可能性のある数字を求める (数字はビットで管理する)
(defun get-numbers (x y)
(logand (aref *xflag* x)
(aref *yflag* y)
(aref *gflag* (get-group x y))))
; フラグの反転
(defun rev-flag (x y n)
(setf (aref *xflag* x)
(logxor (aref *xflag* x) n))
(setf (aref *yflag* y)
(logxor (aref *yflag* y) n))
(setf (aref *gflag* (get-group x y))
(logxor (aref *gflag* (get-group x y)) n)))
; 数字のセット
(defun set-number (x y n)
(setf (aref *board* x y) n)
(rev-flag x y n))
; 数字を取り消す
(defun del-number (x y n)
(setf (aref *board* x y) 0)
(rev-flag x y n))
;;; 盤面の表示
(defun print-board (board)
(dotimes (y *size* (terpri))
(dotimes (x *size* (terpri))
(format t "~D " (1+ (logcount (- (aref board x y))))))))
;;; 初期化
(defun initialize-number-place (size)
(setf *board* (make-array (list size size) :initial-element 0)
*xflag* (make-array size :initial-element (1- (expt 2 size)))
*yflag* (make-array size :initial-element (1- (expt 2 size)))
*gflag* (make-array size :initial-element (1- (expt 2 size)))))
;;; データの読み込み
(defun read-data (ls)
(dotimes (y *size*)
(dotimes (x *size*)
(let ((n (pop ls)))
(if (and (integerp n) (<= 0 n *size*))
(when (plusp n)
(set-number x y (ash 1 (1- n))))
(error "read error ~D (~D, ~D)~%" n x y))))))
; ナンバープレースの解法
(defun number-place9 (data)
(labels ((solve (x y)
(cond ((= y *size*)
(print-board *board*))
((= x *size*)
(solve 0 (1+ y)))
((zerop (aref *board* x y))
(dobit (z (get-numbers x y))
(set-number x y z)
(solve (1+ x) y)
(del-number x y z)))
(t (solve (1+ x) y)))))
(initialize-number-place *size*)
(read-data data)
(solve 0 0)))
それでは、実際に数独を解いてみましょう。Puzzle Generater Japan にある Java版標準問題集 より問題 8-a, 8-b, 9-a, 9-b, 10-a, 10-b を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : 時間 ------+------+------ 8-a : 20 : 0.10 8-b : 20 : 0.28 9-a : 20 : 0.35 9-b : 21 : 0.14 10-a : 22 : 0.03 10-b : 22 : 0.06 実行環境 : Windows XP, celeron 1.40 GHz, SBCL ver 1.0.37
盤面が 9 * 9 の場合、単純なバックトラック法だけでも高速に解くことができました。もちろん、バックトラック法を使わずに解く方法もあります。興味のある方は拙作のページ Scheme Programming パズルの解法 [4] [5] [6] [7] をお読みください。