プログラムを作っていると、ほかのプログラムで作った関数が利用できるのではないか、といった場面に出あうことがあります。このような場合、自分で作成した関数をライブラリとしてまとめておくと、簡単に再利用することができて便利です。
ライブラリの作成で問題になるのが「名前の衝突」です。複数のライブラリを使うときに、同じ名前の関数や変数が存在すると、そのライブラリは正常に動作しないでしょう。このような名前の衝突を避けるために、Common Lisp では「パッケージ (package)」を使います。次の例を見てください。
;;; ファイル bar.lisp (defpackage :bar (:use :cl)) (in-package :bar) (defvar aaa 10) (defvar bbb 20) (defun test () (print "package bar"))
このファイルを関数 load でロードしてから、次のプログラムを実行します。
* (load "bar.lisp")
T
* *package*
#<PACKAGE "COMMON-LISP-USER">
* (package-nicknames :common-lisp-user)
("CL-USER")
* (setq aaa 100)
100
* aaa
100
* bar::aaa
10
defpackage はパッケージを定義するマクロです。あとで詳しく説明しますが、ここでは BAR という名前のパッケージを定義しています。パッケージ名はシンボル、キーワードシンボル、文字列などで指定します。:bar のかわりに bar や "BAR" としてもかまいません。本稿ではキーワードシンボルを使うことにします。
マクロ in-package は、シンボルが所属するパッケージを指定します。Lisp 処理系は、スペシャル変数 *PACKAGE* の値を「カレントパッケージ」として扱い、このパッケージの中からシンボルを探したり、シンボルを新規に登録します。in-package は *PACKAGE* の値を切り替えます。これ以降、ファイル bar.lisp で定義される関数や変数名はパッケージ BAR に属します。
通常、カレントパッケージは COMMON-LISP-USER という、Lisp 処理系があらかじめ用意しているパッケージになっています。パッケージにはニックネームを付けることができ、ニックネームでパッケージを指定することもできます。COMMON-LISP-USER には CL-USER というニックネームが付けられています。REPL で定義する変数や関数は CL-USER に登録されます。したがって、最初 AAA に 100 を代入しましたが、この変数はパッケージ CL-USER 内に定義されます。
ほかのパッケージの変数や関数は、パッケージ名::名前 のようにアクセスすることができます。これを「パッケージ修飾子」といいます。パッケージ BAR の変数 AAA は、BAR::AAA でアクセスすることができ、その値は 10 になります。このように、同じ変数名 AAA でも、パッケージによって区別されるのです。変数 AAA が衝突することはありません。
関数の呼び出しも同じです。BAR に定義されている関数 test は、次のように呼び出すことができます。
* (bar::test) "package bar" "package bar"
大昔の Lisp 処理系では、システム内のシンボルを oblist というリストで管理していました。近代的な Lisp 処理系では、ハッシュ表を使って管理するのが一般的です。パッケージは「複数のハッシュ表を使ってシンボルを管理するシステム」と考えてください。パッケージ CL-USER に定義されているシンボルは、CL-USER に対応するハッシュ表に登録され、BAR で使用されているシンボルは、BAR に対応するハッシュ表に登録されるのです。そして、使用するハッシュ表を決めるのがカレントパッケージなのです。
ところで、異なるパッケージの変数や関数を使うときに、いちいちパッケージ修飾子をつけるのは面倒ですね。このため Common Lisp には、ほかのパッケージで定義された名前を取り込む機能「インポート (import)」が用意されています。ただし、このためにはパッケージ側でも名前を外へ出すための準備が必要です。これを「エキスポート (export)」といいます。エキスポートされたシンボルを「外部シンボル (external symbol)」といい、そうでないシンボルを「内部シンボル (internal symbol)」といいます。パッケージには、この 2 種類のシンボルがあるのです。
シンボルをエキスポートするには関数 export を使います。
export symbols &optional package
引数 symbols はシンボルのリストか、ただひとつのシンボルでなければいけません。これらのシンボルは、パッケージ package の外部シンボルとしてアクセスすることができます。package が省略されると、カレントパッケージが対象となります。簡単な例を示しましょう。
;;; ファイル bar.lisp (defpackage :bar (:use :cl)) (in-package :bar) (export '(aaa bbb test)) (defvar aaa 10) (defvar bbb 20) (defun test () (print "package bar"))
これで、シンボル aaa, bbb, test がエキスポートされます。
シンボルをインポートするには関数 import を使います。
import symbols &optional package
引数 symbols は export と同じです。これらのシンボルは package 内でパッケージ修飾子なしでアクセスできるようになります。これらのシンボルが、すでに package 内に存在する場合はエラーとなります。パッケージ bar のシンボル aaa, test をインポートするには、次のように指定します。
(import '(bar:aaa bar:test))
エキスポートされているシンボルのパッケージ修飾子は「パッケージ名:名前」となります。これで、aaa と test をパッケージ修飾子なしで利用することができます。エキスポートされているシンボルをすべてインポートしたい場合は、関数 use-package を使うと便利です。
use-package packages-to-use &optional package
引数 packages-to-use はパッケージかパッケージの名前のリストです。ひとつしかない場合は、それをそのまま与えてもかまいません。パッケージ bar の外部シンボルをすべてインポートするには、次のように指定します。
(use-package "bar")
これで、エキスポートされている aaa, bbb, test を利用することができます。
なお、export や use-package は defpackage でも行うことができます。Common Lisp の場合、パッケージの定義する関数 make-package がありますが、マクロ defpackage を使った方が簡単です。
defpackage package-name &rest options
package-name には、パッケージ名を表すシンボル、キーワードシンボル、文字列などを与えます。よく使われる options を次に示します。
ところで、ファイル bar.lisp の defpackage で (:use :cl) を指定していますが、CL はパッケージ COMMON-LISP のニックネームです。CL は ANSI Common Lisp の機能を提供するパッケージです。SBCL の場合、この指定がないと標準的な関数を使う場合でもパッケージ修飾子 cl: が必要になります。
パッケージのロードは、プログラムファイルのロードと同じです。関数 load を使うことができますが、このほかに、モジュールをロードする require という関数が用意されています。
「モジュール (modules)」を簡単に説明すると、ある機能を実現するためのプログラムの集まりや構造のことです。たとえば、以前にキューや二分探索木を扱うプログラムを作成しました。そのプログラムにはデータ構造の定義と基本的な操作関数が複数ありますが、それらをひとつにまとめてモジュールとして考えることができます。
provide modules-name require modules-name &optional path-name
provide はモジュール名を定義する関数です。modules-name は、モジュール名を表す文字列かシンボルです。provide はファイルの先頭に書いておきます。require はモジュールをロードする関数です。モジュール名とファイル名は同じにしておくのが一般的です。
ロードされたモジュールはグローバル変数 *MODULES* に登録されます。require でモジュールをロードするときに *MODULES* をチェックして、モジュールがロード済みであればロードしません。
簡単な例を示しましょう。
;;; ファイル bar.lisp (provide :bar) (defpackage :bar (:use :cl)) (in-package :bar) (export '(aaa bbb test)) (defvar aaa 10) (defvar bbb 20) (defun test () (print "package bar"))
ファイル bar.lisp の先頭に (provide :bar) を記述します。bar.lisp がカレントディレクトリにあるならば、次のように require でモジュール BAR をロードすることができます。
* (require :bar "bar.lisp")
("BAR")
* *modules*
("BAR")
* (use-package :bar)
T
* aaa
10
* bbb
20
* (test)
"package bar"
"package bar"
それでは、以前に作成したキューをモジュールにしてみましょう。次のリストを見てください。
リスト : モジュール QUEUE の定義
(provide :queue)
(defpackage :queue (:use :cl))
(in-package :queue)
(export '(make-queue emptyp enqueue dequeue))
;;; キューの定義
(defstruct queue (front nil) (rear nil))
;;; キューは空か？
(defun emptyp (q)
(null (queue-front q)))
;;; データの挿入
(defun enqueue (q item)
(let ((new-cell (list item)))
(if (emptyp q)
;; キューは空の状態
(setf (queue-front q) new-cell)
;; 最終セルを書き換える
(setf (cdr (queue-rear q)) new-cell))
(setf (queue-rear q) new-cell))
;; item を返す
item)
;;; データを取得
(defun dequeue (q)
(unless (emptyp q)
(prog1
(pop (queue-front q))
(when (emptyp q)
;; キューは空になった
(setf (queue-rear q) nil)))))
モジュール QUEUE は、次のように利用することができます。
* (require :queue "queue.lisp")
("QUEUE")
* (defvar q (queue:make-queue))
Q
* (dotimes (x 10) (queue:enqueue q x))
NIL
* (loop (if (queue:emptyp q) (return)) (print (queue:dequeue q)))
0
1
2
3
4
5
6
7
8
9
NIL
(use-package :queue) を評価すれば queue: を省略することもできます。
自分で作ったマクロも、パッケージにまとめておくと簡単に再利用することができます。この場合、ソースファイルをコンパイルするときに注意が必要です。簡単な例題として、prog3 というマクロを作りましょう。
prog1 が最初に評価した S 式の値、prog2 が 2 番目に評価した S 式の値を返すように、prog3 は 3 番目に評価した S 式の値を返します。このマクロをパッケージ mymacro に格納することにします。パッケージの定義は次のようになります。
リスト : パッケージ mymacro
(defpackage :mymacro (:use :cl))
(in-package :mymacro)
(export '(prog3))
; マクロの定義
(defmacro prog3 (first second third &rest body)
`(progn
,first
,second
(prog1
,third
,@body)))
パッケージ mymacro を使う場合は、require でマクロをロードすればいいのですね。たとえば、test_macro.lisp で mymacro を使うには、次のようにします。
リスト : test_macro.lisp (require :mymacro "mymacro.lisp") (use-package :mymacro) (defun foo (a b) (prog3 (+ a b) (- a b) (* a b) (/ a b)))
これでマクロ prog3 を使うことができます。実際に試してみましょう。
* (load "test_macro.lisp") T * (foo 10 20) 200
正常に動作していますね。ところが、test_macro.lisp を関数 compile-file でコンパイルする場合、これでは動作しないのです。SBCL の場合、compile-file は引数のファイルをコンパイルして fasl ファイル (拡張子が .fasl のファイル) を生成します。
* (compile-file "test_macro.lisp") => ワーニング undefined function: PROG3
関数 prog3 が定義されていないとワーニングが表示されます。実際に test_macro.fasl をロードして実行するとエラーが通知されます。
* (load "test_macro.fasl") T * (foo 10 20) => エラー "The function MYMACRO:PROG3 is undefined."
マクロはバイトコンパイルするときにマクロ展開されます。(require :mymacro "mymacro.lisp") とありますが、mymacro.lisp をロードするコードにコンパイルされるだけで、実際にロードされるわけではありません。つまり、コンパイラは prog3 がマクロであることを認識していないのです。このため、コンパイラは関数呼び出しのコードを出力するのですが、prog3 という関数は存在しないため、foo を実行するとエラーになるのです。
したがって、コンパイルするときにも mymacro.lisp を実際にロードしなければいけません。このために用意されている関数 (特殊形式) が eval-when です。
eval-when ({situation}*) Ｓ式
eval-when は「situation (状況)」で指定した状況においてのみ、本体の S 式を評価します。situation には次の 3 種類があります。
eval-when の使い方はけっこう難しいです。xyzzy Lisp のリファレンスには、次のように書いてありました。
よくわからなかったら、3 つ全部つけておけば大丈夫という説もある^^;
この教えに従うと、test_macro.l は次のようになります。
リスト : test_macro.lisp (eval-when (:compile-toplevel :load-toplevel :execute) (require :mymacro "mymacro.lisp") (use-package :mymacro)) (defun foo (a b) (prog3 (+ a b) (- a b) (* a b) (/ a b)))
これで prog3 をマクロとしてコンパイルできます。そして、test_macro.fasl をロードすれば、関数 foo を実行することができます。
* (compile-file "test_macro.lisp") ; 省略 (ワーニングはない) #P"/home/mhiroi/work/lisp/test_macro.fasl" NIL NIL * ^D <-- 終了 $ rlwrap sbcl ・・・省略・・・ * (load "test_macro.fasl") T * (foo 10 20) 200
もちろん、(load "test_macro.lisp") としても正常に動作します。
$ rlwrap sbcl ・・・省略・・・ * (load "test_macro.lisp") T * (foo 10 20) 200
今回はリストを使って「集合 (set)」を表してみましょう。たとえば、{1, 3, 5, 7} という集合は、リストを使って (1 3 5 7) と表すことができます。集合は要素の順番に意味はないので、集合 {1, 3, 5, 7} は (1 3 5 7) だけではなく、(7 5 3 1) や (5 3 1 7) と表すこともできます。このように、要素は適当に並べてもかまわないのですが、ある規則で要素を整列させておく場合 (正規化) もあります。
集合をリストで表す場合、関数 member は要素が集合に含まれているか調べる述語と考えることができます。このほかにも、集合 A は集合 B の部分集合か調べたり、集合 A と B の和や積を求める、といった操作を考えることができます。Common Lisp にはリストを集合として操作する関数が用意されていますが、私達でも簡単にプログラムすることができます。
最初は XS と YS の和集合を求める関数 union を作りましょう。union は 2 つのリスト XS, YS を受け取り、2 つの集合の要素をすべて含むリストを返します。このとき、2 つの集合で重複している要素はひとつだけ結果のリストに含まれます。簡単な例を示しましょう。
(union '(a b c) '(d e f)) => (A B C D E F) (union '(a b c) '(c b d)) => (A C B D)
Common Lisp には union が用意されているので、関数名は my-union とします。my-union は append と同じように作ることができます。第 1 引数のリストから要素を取り出し、それが第 2 引数のリストに含まれていなければ、その要素を結果のリストに追加します。含まれていれば、その要素は追加しません。そして最後に、第 2 引数のリストを追加します。プログラムは次のようになります。
リスト : 和集合
(defun my-union (xs ys)
(cond
((null xs) ys)
((member (car xs) ys)
(my-union (cdr xs) ys))
(t
(cons (car xs) (my-union (cdr xs) ys)))))
リスト XS の要素を car で取り出して、同じ要素がリスト YS に含まれているか member でチェックします。含まれていれば my-union を再帰呼び出します。そうでなければ、my-union を再帰呼び出しした結果に要素を追加します。それでは実行してみましょう。
* (my-union '(1 2 3 4) '(3 4 5 6)) (1 2 3 4 5 6) * (my-union '(1 2 3 4) '(5 6 7 8)) (1 2 3 4 5 6 7 8) * (my-union '(1 2 3 4) '(1 2 3 4)) (1 2 3 4)
次は積集合を求める関数 intersection を作ります。intersection は 2 つのリストに共通な要素を取り出し、それをリストに格納して返します。簡単な例を示しましょう。
(intersection '(a b c) '(b c d)) => (C B) (intersection '(a b c) '(d e f)) => NIL
Common Lisp には intersection が用意されているので、関数名は my-intersection としました。プログラムは次のようになります。
リスト : 積集合
(defun my-intersection (xs ys)
(cond
((null xs) nil)
((member (car xs) ys)
(cons (car xs) (my-intersection (cdr xs) ys)))
(t
(my-intersection (cdr xs) ys))))
これも簡単ですね。リスト XS の要素を car で取り出して、同じ要素がリスト YS に含まれているか member でチェックします。含まれていれば、my-intersection を再帰呼び出しした結果に要素を追加します。そうでなければ、my-intersection を再帰呼び出しするだけです。実行結果は次のようになります。
* (my-intersection '(1 2 3 4) '(3 4 5 6)) (3 4) * (my-intersection '(1 2 3 4) '(5 6 7 8)) NIL * (my-intersection '(1 2 3 4) '(1 2 3 4)) (1 2 3 4)
次は差集合を求める関数 difference を作りましょう。difference は 2 つのリスト XS, YS を受け取り、XS から YS に含まれている要素を取り除きます。つまり、XS にあって YS にはない要素を格納して返します。簡単な例を示しましょう。
(difference '(a b c) '(b c d)) => (A) (difference '(a b c) '(d e f)) => (A B C)
Common Lisp には set-difference が用意されています。関数名は my-difference としました。プログラムは次のようになります。
リスト : 差集合
(defun my-difference (xs ys)
(cond
((null xs) nil)
((member (car xs) ys)
(my-difference (cdr xs) ys))
(t
(cons (car xs) (my-difference (cdr xs) ys)))))
これも簡単ですね。リスト XS の要素を car で取り出して、同じ要素がリスト YS に含まれているか member でチェックします。含まれていれば、my-difference を再帰呼び出しします。そうでなければ、my-difference を再帰呼び出しした結果に要素を追加します。実行結果は次のようになります。
* (my-difference '(1 2 3 4) '(3 4 5 6)) (1 2) * (my-difference '(1 2 3 4) '(5 6 7 8)) (1 2 3 4) * (my-difference '(1 2 3 4) '(1 2 3 4)) NIL
次は XS が YS の部分集合か判定する述語 subsetp を作りましょう。subsetp は XS の要素がすべて YS に含まれていれば真を返します。YS には含まれない要素が XS にひとつでもあれば偽を返します。簡単な例を示しましょう。
(subsetp nil '(a b c d)) => T (subsetp '(a b c) '(a b c d)) => T (subsetp '(a b e) '(a b c d)) => NIL
Common Lisp には subsetp が用意されているので、関数名は my-subsetp としました。プログラムは次のようになります。
リスト : 部分集合の判定
(defun my-subsetp (xs ys)
(cond
((null xs) t)
((member (car xs) ys)
(my-subsetp (cdr xs) ys))
(t nil)))
引数 XS が空リストならば T を返します。次の節で、リスト XS の要素を car で取り出して、同じ要素がリスト YS に含まれているか member でチェックします。含まれていれば、my-subsetp を再帰呼び出しします。そうでなければ、YS に含まれていない要素が XS にあるので NIL を返します。実行結果は次のようになります。
* (my-subsetp nil '(1 2 3 4)) T * (my-subsetp '(3 4) '(1 2 3 4)) T * (my-subsetp '(3 4 5) '(1 2 3 4)) NIL * (my-subsetp '(1 2 3 4) '(1 2 3 4)) T
最後に、Common Lisp に用意されている関数を表にまとめます。
| 関数名 | 機能 |
|---|---|
| union list1 list2 | list1 と list2 の和を求める |
| intersection list1 list2 | list1 と list2 の積を求める |
| set-difference list1 list2 | list2 に含まれない list1 の要素をリストにして返す |
| set-exclusive-or list1 list2 | list1 と list2 の両方にちょうど 1 つだけ現れる要素をリストにして返す |
| subsetp list1 list2 | list1 の要素がすべて list2 に含まれていれば真を返す |
これらの関数はキーワード :key, :test, :test-not を使うことができます。簡単な使用例を示しましょう。
* (union '((1 2) (3 4)) '((5 6) (1 2))) ((1 2) (3 4) (5 6) (1 2)) ; :test のデフォルトは eql * (union '((1 2) (3 4)) '((5 6) (1 2)) :test #'equal) ((3 4) (5 6) (1 2)) * (union '((a 1) (b 2)) '((c 1) (a 3)) :key #'car) ((b 2) (c 1) (a 3)) * (set-difference '(1 2 3 4) '(3 4 5 6)) (2 1) * (set-exclusive-or '(1 2 3 4 5 6) '(4 5 6 2 7 8)) (3 1 8 7) * (subsetp '(1 2) '(1 2 3)) T * (subsetp '(0 1 2) '(1 2 3)) NIL
それでは簡単な例題として「嫉妬深い夫の問題」というパズルを解いてみましょう。これは「川渡りの問題」と呼ばれる古典的なパズルの一種です。このパズルにはたくさんのバリエーションがありますが、その中で「農夫と山羊と狼とキャベツの問題」や「宣教師と先住民」というパズルが有名です。
3 組の夫婦が川を渡ることになりました。ボートには 2 人しか乗ることができません。どの夫も嫉妬深く、彼自身が一緒にいない限り、ボートでも岸でも妻がほかの男といることを許しません。なお、6 人ともボートを漕ぐことができます。この条件で、3 組の夫婦が川を渡る最短手順を求めてください。
それではプログラムを作りましょう。この問題は、単純な反復深化でも簡単に最短手順を求めることができます。今回は左岸から右岸へ渡ることにします。
まず最初に、夫婦と岸の状態を表すデータ構造を決めます。いろいろな方法が考えられますが、今回は 3 組の夫婦をシンボル HA, WA, HB, WB, HC, WC で、岸の状態をリストで表すことにします。ボートがある場合はリストの先頭に T をセットし、無い場合は NIL をセットします。H で始まるシンボルが夫、W で始まるシンボルが妻を表します。最初の状態は、左岸が (T HA HB HC WA WB WC) で右岸が (NIL) となります。
次は、岸やボートの状態が安全かチェックする関数 safep を作ります。次のリストを見てください。
リスト : 安全確認
(defun safep (xs)
(let ((hs (intersection xs '(ha hb hc)))
(ws (intersection xs '(wa wb wc))))
(if (or (null ws) (null hs))
;; 異性がいなければ安全
t
(every (lambda (w)
;; 夫がいれば安全
(member (cdr (assoc w '((wa . ha) (wb . hb) (wc . hc)))) hs))
ws))))
引数 XS はボートや岸にいる人を表すリストです。まず最初に、XS から男性と女性を取り出して変数 HS と WS にセットします。この処理は関数 intersection を使えば簡単です。HS または WS が空リストならば異性がいないので安全です。T を返します
問題になるのは、男性と女性がいっしょにいる場合です。このときは、女性の夫がいっしょにいるかチェックします。every で WS から女性をひとりずつ変数 W に取り出して、その夫が HS に含まれているか member でチェックします。夫婦は連想リストで表していて、assoc で W の夫を求めています。夫がいっしょにいなければ危険な状態なので NIL を返します。WS の夫が全員いれば安全な状態なので T を返します。
次は、ボートに乗る組み合わせをすべて求める関数 ride-board を作ります。これは組み合わせを求める関数 combination を使うと簡単です。プログラムは次のようになります。
リスト : ボートに乗る組み合わせ
;;; 組み合わせの生成
(defun combination (xs r)
(cond
((zerop r) '(()))
((null xs) nil)
(t (append (mapcar (lambda (ys) (cons (car xs) ys))
(combination (cdr xs) (1- r)))
(combination (cdr xs) r)))))
;;; ボートに乗る組み合わせ
(defun ride-board (xs)
(remove-if-not #'safep (append (combination xs 1) (combination xs 2))))
combination で一人乗る組み合わせと二人乗る組み合わせを生成して append で連結します。あとは remove-if-not で危険な組み合わせを取り除くだけです。
次は手数 LIMIT まで深さ優先探索を行う関数 dfs を作ります。
リスト : 反復深化用深さ優先探索
;;; 等値の判定
(defun eqlsetp (xs ys)
(and (subsetp xs ys) (subsetp ys xs)))
;;; 深さ優先探索
(defun dfs (n limit from to)
(cond
((= n limit)
(unless (cdar to)
(print-answer (reverse to) (reverse from))
(throw 'find-answer t)))
(t
;; ボートを動かす
(dolist (xs (ride-board (cdar from)))
(let ((newfrom (cons nil (set-difference (cdar from) xs)))
(newto (cons t (union (cdar to) xs))))
(when (and (safep newfrom)
(safep newto)
(not (member newfrom from :test #'eqlsetp)))
(dfs (1+ n) limit (cons newto to) (cons newfrom from))))))))
引数 N が手数、LIMIT が反復深化の上限値、FROM と TO は岸の状態の履歴を格納するリストです。ボートがある岸の状態が FROM で、対岸の状態が TO です。リストの先頭の要素が現在の状態を表します。
N が LIMIT に達したら、全員が右岸へ渡ったかチェックします。ボートが右岸にあるときは N が奇数なので、LIMIT には奇数を設定することに注意してください。このとき、左岸にいる人 (cdar to) が空リストであれば、全員が右岸へ渡ったことになります。関数 print-answer で手順を表示してから throw で大域脱出します。
N が LIMIT 未満ならば、ボートを FROM から TO へ動かします。dolist でボートに乗る組み合わせを変数 XS にセットします。両岸の人の状態を cdar で取り出して、FROM 側から XS を取り除き、TO 側に XS を追加します。これらの処理は関数 set-difference と union を使えば簡単です。そして、FROM 側の先頭に NIL を、TO 側の先頭に T を追加して、変数 NEWFROM と NEWTO にセットします。
あとは safep で NEWFROM と NEWTO が安全であることを確認します。リストの先頭には NIL または T がありますが、そのまま safep に渡しても正常に動作します。それから、member で同一局面のチェックを行います。これは片側の岸だけ行えば十分です。
要素はリストですが集合として扱っているので、:test に #'equal を指定しても動作しません。集合の等値をチェックする述語 eqlsetp を定義して、それを :test に指定します。eqlsetp は簡単です。XS が YS の部分集合で、かつ YS が XS の部分集合であれば、XS と YS は等しいことが分かります。両岸の状態が安全で同一局面が無ければ dfs を再帰呼び出しします。
最後に、反復深化でパズルを解く関数 solver-id を作ります。
リスト : 「嫉妬深い夫の問題」の解法
(defun solver-id ()
(catch 'find-answer
(do ((limit 9 (+ limit 2)))
((> limit 20))
(format t "----- ~D 手を探索 -----~%" limit)
;; 初手を (ha wa) に限定
(dfs 1 limit '((t ha wa) (nil)) '((nil hb hc wb wc) (t ha hb hc wa wb wc))))))
制約のない 6 人が 2 人乗りのボートで川を渡る場合、1 往復で対岸に渡ることができる人数は 1 人ですから、4 往復で 4 人を対岸へ送ってから最後に 2 人が対岸へ渡ることになります。したがって LIMIT の初期値は 9 手に設定します。
また、最初にボートに乗る組み合わせは夫婦、女性 2 人、男性 2 人の 3 通りありますが、男性 2 人が乗り込む場合は条件を満たさないので、初手は夫婦か女性 2 人の 2 通りしかありません。そこで、今回は初手を夫婦 (ha wa) に限定しました。興味のある方は、ほかの組み合わせでも試してみてください。
これでプログラムは完成です。さっそく実行してみましょう。
* (solver-id) ----- 9 手を探索 ----- ----- 11 手を探索 ----- 0 : (T HA HB HC WA WB WC) (NIL) 1 : (NIL HB HC WB WC) (T HA WA) 2 : (T WC WB HC HB HA) (NIL WA) 3 : (NIL HA HB HC) (T WB WC WA) 4 : (T HC HB HA WB) (NIL WA WC) 5 : (NIL WB HB) (T WC WA HC HA) 6 : (T HB WB WC HC) (NIL HA WA) 7 : (NIL WC WB) (T WA HA HB HC) 8 : (T WB WC WA) (NIL HC HB HA) 9 : (NIL WA) (T HA HB HC WB WC) 10 : (T WA HA) (NIL WC WB HC HB) 11 : (NIL) (T HB HC WB WC WA HA) T
11 手で解くことができました。関数 print-answer はリストを表示しているだけなので、手順はちょっとわかりにくいかもしれません。手順をきれいに表示することは皆さんにお任せしたいと思います。
ところで、もっと簡単にプログラムできると思っていたのですが、ちょっと複雑なプログラムになってしまいました。データ構造を工夫すると、もっと簡単にプログラムできるかもしれません。興味のある方はプログラムを改造してみてください。
;;;
;;; husband.lisp : 嫉妬深い夫の問題
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
;;; 組み合わせの生成
(defun combination (xs r)
(cond
((zerop r) '(()))
((null xs) nil)
(t (append (mapcar (lambda (ys) (cons (car xs) ys))
(combination (cdr xs) (1- r)))
(combination (cdr xs) r)))))
;;; 夫 : ha, hb, hc
;;; 妻 : wa, wb, wc
;;; 安全確認
(defun safep (xs)
(let ((hs (intersection xs '(ha hb hc)))
(ws (intersection xs '(wa wb wc))))
(if (or (null ws) (null hs))
;; 異性がいなければ安全
t
(every (lambda (w)
;; 夫がいれば安全
(member (cdr (assoc w '((wa . ha) (wb . hb) (wc . hc)))) hs))
ws))))
;;; ボートに乗る組み合わせ
(defun ride-board (xs)
(remove-if-not #'safep (append (combination xs 1) (combination xs 2))))
;;; 等値の判定
(defun eqlsetp (xs ys)
(and (subsetp xs ys) (subsetp ys xs)))
;;; 解の表示
(defun print-answer (from to &optional (n 0))
(when (and from to)
(format t "~D : ~S ~S~%" n (car from) (car to))
(print-answer (cdr from) (cdr to) (1+ n))))
;;; 反復深化用深さ優先探索
(defun dfs (n limit from to)
(cond
((= n limit)
(unless (cdar to)
(print-answer (reverse to) (reverse from))
(throw 'find-answer t)))
(t
;; ボートを動かす
(dolist (xs (ride-board (cdar from)))
(let ((newfrom (cons nil (set-difference (cdar from) xs)))
(newto (cons t (union (cdar to) xs))))
(when (and (safep newfrom)
(safep newto)
(not (member newfrom from :test #'eqlsetp)))
(dfs (1+ n) limit (cons newto to) (cons newfrom from))))))))
;;; パズルの解法
(defun solver-id ()
(catch 'find-answer
(do ((limit 9 (+ limit 2)))
((> limit 20))
(format t "----- ~D 手を探索 -----~%" limit)
;; 初手を (ha wa) に限定
(dfs 1 limit '((t ha wa) (nil)) '((nil hb hc wb wc) (t ha hb hc wa wb wc))))))
リスト : 和集合 (別解)
(defun my-union1 (xs ys)
(let ((zs ys))
(dolist (x xs zs)
(pushnew x zs))))
(defun my-union2 (xs ys)
(reduce #'(lambda (a x) (if (member x ys) a (cons x a)))
xs
:initial-value ys))
* (my-union1 '(1 2 3 4) '(3 4 5 6)) (2 1 3 4 5 6) * (my-union2 '(1 2 3 4) '(3 4 5 6)) (2 1 3 4 5 6)
リスト : 積集合 (別解)
(defun my-intersection1 (xs ys)
(let ((zs nil))
(dolist (x xs zs)
(when (member x ys)
(push x zs)))))
(defun my-intersection2 (xs ys)
(reduce #'(lambda (a x) (if (member x ys) (cons x a) a))
xs
:initial-value nil))
* (my-intersection1 '(1 2 3 4) '(3 4 5 6)) (4 3) * (my-intersection2 '(1 2 3 4) '(3 4 5 6)) (4 3)
リスト : 差集合 (別解)
(defun my-difference1 (xs ys)
(let ((zs nil))
(dolist (x xs zs)
(unless (member x ys)
(push x zs)))))
(defun my-difference2 (xs ys)
(reduce #'(lambda (a x) (if (member x ys) a (cons x a)))
xs
:initial-value nil))
* (my-difference1 '(1 2 3 4) '(3 4 5 6)) (2 1) * (my-difference2 '(1 2 3 4) '(3 4 5 6)) (2 1)
リスト : 部分集合の判定 (別解)
(defun my-subsetp1 (xs ys)
(dolist (x xs t)
(unless (member x ys) (return))))
(defun my-subsetp2 (xs ys)
(every (lambda (x) (member x ys)) xs))
* (my-subsetp1 '(2 3) '(1 2 3 4)) T * (my-subsetp1 '(2 3 5) '(1 2 3 4)) NIL * (my-subsetp2 '(2 3) '(1 2 3 4)) T * (my-subsetp2 '(2 3 5) '(1 2 3 4)) NIL
リスト : べき集合
(defun power-set (xs)
(if (null xs)
'(())
(append (power-set (cdr xs))
(mapcar (lambda (ys) (cons (car xs) ys))
(power-set (cdr xs))))))
べき集合を求める関数 power-set は簡単です。XS が空リストの場合は NIL を格納したリストを返します。そうでなければ power-set を再帰呼び出しして (cdr xs) のべき集合を求め、その集合に先頭要素 (car xs) を追加します。そして、その集合と (cdr xs) のべき集合を append で連結します。
* (power-set '(a b c)) (NIL (C) (B) (B C) (A) (A C) (A B) (A B C)) * (power-set '(a b c d)) (NIL (D) (C) (C D) (B) (B D) (B C) (B C D) (A) (A D) (A C) (A C D) (A B) (A B D) (A B C) (A B C D))
リスト : 直積集合
(defun product-set (xs ys)
(mapcan (lambda (x)
(mapcar (lambda (y) (list x y)) ys))
xs))
直積集合はマップ関数を二重にすれば簡単です。リストを平坦化するため mapcan を使っていることに注意してください。
* (product-set '(a b) '(c d)) ((A C) (A D) (B C) (B D)) * (product-set '(a b c) '(d e)) ((A D) (A E) (B D) (B E) (C D) (C E)) * (product-set '(a b c) '(d e f)) ((A D) (A E) (A F) (B D) (B E) (B F) (C D) (C E) (C F))