Functional Programming

非決定性 (2)

今回は非決定性計算を幅優先探索で行う方法について説明します。参考文献は Paul Graham 著，野田 開 訳, On Lisp です。

●amb は深さ優先探索

前回作成した amb は、一つ前に実行した amb の継続を局所変数 prev-fail に保存して、*amb-fail* をバックトラックする継続に書き換えています。この処理は *amb-fail* をスタックとして使用すると簡単に実現することができます。つまり、継続を *amb-fail* にプッシュしておいて、バットラックするときは *amb-fail* から継続をポップして実行します。この方法だと深さ優先探索していることがよくわかると思います。プログラムは次のようになります。

なお、前回と同様に今回のプログラムでも拙作のライブラリ (mylib list) を使います。

;;;
;;; amb1.scm : 非決定性 (深さ優先探索)
;;;
;;;            Copyright (C) Makoto Hiroi
;;;
(define-library (mylib amb1)
  (import (scheme base) (mylib list))
  (export *amb-fail* initialize-amb-fail fail amb-f amb assert bag-of)
  (begin
    ;; 継続を格納するスタック
    (define *amb-fail* #f)

    ;; 初期化
    (define (initialize-amb-fail)
      (set! *amb-fail* '()))

    ;; スタックから継続を取り出してバックトラックする
    (define (fail)
      (if (null? *amb-fail*)
          (error "amb tree exhausted")
          (let ((proc (car *amb-fail*)))
            (set! *amb-fail* (cdr *amb-fail*))
            (proc))))

    ;; 非決定性
    ;; 関数版
    (define (amb-f . args)
      (if (null? args)
          (fail)
          (call/cc
           (lambda (cont-s)
             (for-each
              (lambda (x)
                (call/cc
                 (lambda (cont-f)
                   (set! *amb-fail* (cons (lambda () (cont-f #f)) *amb-fail*))
                   (cont-s x))))
              args)
             (fail)))))

    ;; マクロ版
    (define-syntax amb
      (syntax-rules ()
        ((_) (fail))
        ((_ a) a)
        ((_ a ...)
         (call/cc
          (lambda (cont-s)
            (call/cc
             (lambda (cont-f)
               (set! *amb-fail* (cons (lambda () (cont-f #f)) *amb-fail*))
               (cont-s a)))
            ...
            (fail))))))

    ;; 条件 pred を満たさない場合はバックトラックする
    (define (assert pred)
      (if (not pred) (amb)))

    ;; 見つけた解をリストに格納して返す
    (define-syntax bag-of
      (syntax-rules ()
        ((_ e)
         (let ((results '()))
           (if (call/cc
                (lambda (cont)
                  (set! *amb-fail* (cons (lambda () (cont #f)) *amb-fail*))
                  (set! results (cons e results))
                  (cont #t)))
               (fail))
           (reverse! results)))))
    ))

関数 initialize-amb-faile は大域変数 *amb-fail* を空リストに初期化します。関数 fail は *amb-fail* から pop! で継続を取り出して実行します。*amb-fail* が空リストの場合はエラーを送出します。amb-f は関数版で、amb がマクロ版です。どちらもラムダ式 (lambda () (cont-f #f)) を *amb-fail* に push! してから、継続 cont-s を評価して要素を返します。bag-of の修正も同じです。

●経路の探索

それでは簡単な例題として、拙作のページ 経路の探索 で取り上げた問題を解いてみましょう。経路図を再掲します。

      図 : 経路図

amb を使ったプログラムは次のようになります。

リスト : 経路の探索

;;; 隣接リスト
(define *adjacent*
  '((a b c)
    (b a c d)
    (c a b e)
    (d b e f)
    (e c d g)
    (f d)
    (g e)))

;;; 深さ優先探索
(define (depth-first-search start goal)
  (let loop ((path (list start)))
    (if (eq? (car path) goal)
        (reverse path)
        (let ((x (apply amb-f (assoc (car path) *adjacent*))))
          (assert (not (member x path)))
          (loop (cons x path))))))

隣接リスト *adjacent* は連想リストで表しています。関数 depth-first-search は経路をリスト path で管理します。経路は逆順で管理していることに注意してください。(car path) が goal と等しい場合は (reverse path) を返します。

そうでなければ、amb-f で隣接リストから要素を一つ選びます。この場合、マクロ amb よりも関数 amb-f を使った方が簡単です。apply を使って隣接リストを amb-f に渡します。そして、選んだ要素 x が path に含まれていないことを assert で確認します。最後に、path の先頭に x を追加して探索を続行します。

それでは、実行結果を示しましょう。

gosh[r7rs.user]> (initialize-amb-fail)
()
gosh[r7rs.user]> (depth-first-search 'a 'g)
(a b c e g)
gosh[r7rs.user]> (fail)
(a b d e g)
gosh[r7rs.user]> (fail)
(a c b d e g)
gosh[r7rs.user]> (fail)
(a c e g)
gosh[r7rs.user]> (fail)
*** ERROR: amb tree exhausted

gosh[r7rs.user]> (bag-of (depth-car-search 'a 'g))
((a b c e g) (a b d e g) (a c b d e g) (a c e g))

amb は深さ優先探索なので、最初に見つかる経路が最短経路とは限りません。最短経路を求めるには「幅優先探索」のほうが適しています。

●幅優先探索版 amb の作成

それでは、amb のアルゴリズムを幅優先探索に変更しましょう。基本的には *amb-fail* をスタックからキューに変更するだけですが、それだけでは bag-of の動作が実現できないので、ちょっとした工夫が必要になります。

キューは拙作のページ Scheme プログラミング中級編 [4] で説明しました。今回はそのプログラムをレコード型に改造し、ライブラリ (mylib queue) にまとめたものを使います。

それでは amb を修正しましょう。次のリストを見てください。

;;;
;;; amb2.scm : 非決定性 (幅優先探索)
;;;
;;;            Copyright (C) Makoto Hiroi
;;;
(define-library (mylib amb2)
  (import (scheme base) (mylib list) (mylib queue))
  (export initialize-amb-fail fail amb-f amb assert bag-of)
  (begin
    ;; キュー
    (define *amb-fail* #f)
    ;; bag-of 用スタック
    (define *bag-fail* #f)

    ;; 初期化
    (define (initialize-amb-fail)
      (set! *amb-fail* (make-queue))
      (set! *bag-fail* '()))

    ;; キューから継続を取り出してバックトラックする
    (define (fail)
      (if (queue-empty? *amb-fail*)
          (if (null? *bag-fail*)
              (error "amb tree exhausted")
              (let ((proc (car *bag-fail*)))
                (set! *bag-fail* (cdr *bag-fail*))
                (proc #f)))
          ((dequeue! *amb-fail*))))

    ;; 非決定性 (幅優先探索)
    ;; マクロ版
    (define-syntax amb
      (syntax-rules ()
        ((_) (fail))
        ((_ a) a)
        ((_ a ...)
         (call/cc
          (lambda (cont)
            (enqueue! *amb-fail* (lambda () (cont a)))
            ...
            (fail))))))

    ;; 条件 pred を満たさない場合はバックトラックする
    (define (assert pred)
      (if (not pred) (amb)))

    ;; 関数版
    (define (amb-f . args)
      (if (null? args)
          (fail)
          (call/cc
           (lambda (cont)
             (for-each
              (lambda (x) (enqueue! *amb-fail* (lambda () (cont x))))
              args)
             (fail)))))

    ;; 見つけた解をリストに格納して返す
    (define-syntax bag-of
      (syntax-rules ()
        ((_ e)
         (let ((results '())
               (prev-fail *amb-fail*))
           (call/cc
            (lambda (cont)
              (set! *amb-fail* (make-queue))
              (set! *bag-fail* (cons cont *bag-fail*))
              (set! results (cons e results))
              (fail)))
           (set! *amb-fail* prev-fail)
           (reverse! results)))))
    ))

マクロ版 amb と関数版 amb-f は簡単です。要素を返すための継続を取り出して cont にセットします。そして、(lambda () (cont a)) をキュー *amb-fail* に追加するだけです。最後に関数 fail を呼び出して、キューに格納された継続を取り出してバックトラックします。amb が最初に呼び出された場合、これで先頭の要素が返されます。

関数 bag-of はちょっと複雑になります。*amb-fail* はキューなので、bag-of の処理を終了するための継続をキューに追加しても動作しません。そこで、新しいキューを生成して *amb-fail* にセットし、引数 e の処理で発生したバックトラックはそのキューに格納します。そして、bag-of の処理を終了するための継続を大域変数 *bag-fail* にセットします。(push! result e) のあと fail を評価すると、引数 e の処理にバックトラックするので、e の評価結果を results に格納していくことができます。

関数 fail は *amb-fail* が空でも *bag-fail* が空リストでなければ、*bag-fail* から継続を取り出して実行します。*bag-fail* はスタックとして使用することに注意してください。これで bag-of の (call/cc ...) の処理が終了し、*amb-fail* を元のキューに戻して (reverse! results) を返します。

それでは、簡単な実行例を示しましょう。

gosh[r7rs.user]> (initialize-amb-fail)
()
gosh[r7rs.user]> (list (amb 1 2 3) (amb 4 5 6))
(1 4)
gosh[r7rs.user]> (fail)
(1 5)
gosh[r7rs.user]> (fail)
(1 6)
gosh[r7rs.user]> (fail)
(2 4)
gosh[r7rs.user]> (fail)
(2 5)
gosh[r7rs.user]> (fail)
(2 6)
gosh[r7rs.user]> (fail)
(3 4)
gosh[r7rs.user]> (fail)
(3 5)
gosh[r7rs.user]> (fail)
(3 6)
gosh[r7rs.user]> (fail)
*** ERROR: amb tree exhausted

gosh[r7rs.user]> (bag-of (list (amb 1 2 3) (amb 4 5 6)))
((1 4) (1 5) (1 6) (2 4) (2 5) (2 6) (3 4) (3 5) (3 6))

amb は幅優先探索なので (list (amb 1 2 3) (amb 4 5 6)) を評価すると、先頭要素が 1 の組から順番に生成されます。

幅優先で「経路の探索」を行うと次のようになります。

gosh[r7rs.user]> (initialize-amb-fail)
()
gosh[r7rs.user]> (breadth-first-search 'a 'g)
(a c e g)
gosh[r7rs.user]> (fail)
(a b c e g)
gosh[r7rs.user]> (fail)
(a b d e g)
gosh[r7rs.user]> (fail)
(a c b d e g)
gosh[r7rs.user]> (fail)
*** ERROR: amb tree exhausted

gosh[r7rs.user]> (bag-of (breadth-first-search 'a 'g))
((a c e g) (a b c e g) (a b d e g) (a c b d e g))

関数 breadth-car-search は経路を幅優先探索します。この関数は depth-car-search の名前を breadth-fisrt-search に変更しただけで、プログラムはまったく同じです。amb が幅優先探索しているので、最初に見つかる経路が最短経路になります。

●水差し問題

それでは簡単な例題としてパズルを解いてみましょう。「水差し問題」はいろいろな呼び方があって、「水をはかる問題」とか「水を測り出す問題」と呼ばれることもあります。それでは問題です。

水差し問題の場合、次に示す 3 通りの操作があります。

1. 容器いっぱいに水を満たす。
2. 容器を空にする。
3. 他の容器に水を移す。

3 の操作は、容器が空になるまで水を移す場合と、もう一方の容器が満杯になるまで水を移す場合があります。容器は 2 つあるので、全部で 6 通りの操作があります。最初に、これらの操作を行う関数を定義します。プログラムは次のようになります。

リスト : 容器の操作

;;; アクセス関数
(define MAX-A 8)
(define MAX-B 5)
(define (get-A state) (car state))
(define (get-B state) (cadr state))

;;; A を満杯にする
(define (full-A state)
  (list MAX-A (get-B state)))

;;; A を空にする
(define (clear-A state)
  (list 0 (get-B state)))

;;; A -> B
(define (A->B state)
  (let ((w (min (get-A state) (- MAX-B (get-B state)))))
    (list (- (get-A state) w) (+ (get-B state) w))))

;;; B を満杯にする
(define (full-B state)
  (list (get-A state) MAX-B))

;;; B を空にする
(define (clear-B state)
  (list (get-A state) 0))

;;; B->A
(define (B->A state)
  (let ((w (min (- MAX-A (get-A state)) (get-B state))))
    (list (+ (get-A state) w) (- (get-B state) w))))

状態はリスト (A B) で表します。A は 8 リットルの容器の水の量、B は 5 リットルの容器の水の量を表します。容器を水で満たす、または空にする操作は簡単ですね。他の容器へ移す場合、たとえば A->B では、B の空き容量と A の水の量を比較して、少ない方が移す水の量 w になります。

あとは amb を使って簡単にプログラムすることができます。次のリストを見てください。

リスト : 水差し問題の解法

(define (solver-water goal)
  (let loop ((path '((0 0))))
    (if (or (= (get-A (car path)) goal)
            (= (get-B (car path)) goal))
        (reverse path)
        (let ((fn (amb full-A clear-A A->B full-B clear-B B->A)))
          (let ((state (fn (car path))))
            (assert (not (member state path)))
            (loop (cons state path)))))))

path に手順を格納します。A または B に水が goal リットルあれば解を見つけることができました。(reverse path) で path を逆順にして返します。そうでなければ、amb で操作関数を一つ選んで fn にセットします。そして、(fn (car path)) で新しい状態を生成して state にセットします。path に同じ状態が見つかった場合はバックトラックします。新しい状態であれば path の先頭に追加して探索を続行します。

深さ優先探索で実行すると次のようになります。

gosh[r7rs.user]> (solver-water 4)
((0 0) (8 0) (3 5) (8 5) (0 5) (5 0) (5 5) (8 2) (0 2) (2 0) (2 5) (7 0) (7 5) (8 4))

これは最短手順ではありません。幅優先探索で実行すると最短手順を求めることができます。

gosh[r7rs.user]> (solve-water 4)
((0 0) (0 5) (5 0) (5 5) (8 2) (0 2) (2 0) (2 5) (7 0) (7 5) (8 4))

このように、最短手順は 10 手になります。

●反復深化

ところで、深さ優先探索の amb を使って「反復深化」を行うこともできます。次のリストを見てください。

;;;
;;; amb3.scm : amb による反復深化
;;;
;;;            Copyright (C) 2020 Makoto Hiroi
;;;
(define-library (mylib amb3)
  (import (scheme base) (mylib amb1) (scheme write))
  (export initialize-amb-fail fail amb-f amb assert bag-of id-search)
  (begin
    ;; 反復深化
    (define (id-search max-limit fn . args)
      (call/cc
       (lambda (exit)
         (do ((limit 1 (+ limit 1)))
             ((> limit max-limit))
           (call/cc
            (lambda (cont)
              (display "----- ") (display limit) (display " -----\n")
              (set! *amb-fail* (cons (lambda () (cont #f)) *amb-fail*))
              (apply fn limit exit args)))))))
    ))

関数 id-search は上限値 limit を 1 から max-limit まで 1 手ずつ増やしながら関数 fn を呼び出します。fn は amb を使って探索を行う関数とします。fn には引数 args のほかに、上限値 limit と解を見つけたときの脱出先継続 exit を渡します。

最初に解を返すための脱出先継続を取り出して exit にセットします。次に、 do ループを使って limit を 1 手ずつ増やしていきます。探索中の手数で解が見つからない場合、*amb-fail* は空リストになるのでエラーが送出されます。そこで、反復深化を続けるための継続を取り出して cont にセットし、それを *amb-fail* にプッシュします。解が見つからない場合、この継続が評価されるので、反復深化を続けることができます。あとは apply で fn を評価するだけです。

なお、display で上限値を表示していますが、表示する必要がなければ削除してください。

●反復深化による経路の探索

それでは id-search を使って「経路の探索」を解いてみましょう。次のリストを見てください。

リスト : 経路の探索 (反復深化)

(define (search limit exit start goal)
  (let loop ((n 1) (path (list start)))
    (if (= n limit)
        (if (eq? (car path) goal)
            (exit (reverse path))
            (fail))
        (let ((x (apply amb-f (assoc (car path) *adjacent*))))
          (assert (not (member x path)))
          (loop (+ n 1) (cons x path))))))

関数 search は上限値 limit まで深さ優先探索を行います。n が節の個数を表します。n が limit と等しくなったら、現在地点 (car path) が goal に到達したかチェックします。そうであれば、継続 exit で経路 (reverse path) を返します。そうでなければ、fail を評価してバックトラックします。あとの処理は深さ優先探索と同じです。

それでは実行してみましょう。

gosh[r7rs.user]> (initialize-amb-fail)
()
gosh[r7rs.user]> (id-search 7 search 'a 'g)
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
(a c e g)
gosh[r7rs.user]> (fail)
----- 5 -----
(a b c e g)
gosh[r7rs.user]> (fail)
(a b d e g)
gosh[r7rs.user]> (fail)
----- 6 -----
(a c b d e g)
gosh[r7rs.user]> (fail)
----- 7 -----
#t
gosh[r7rs.user]> (fail)
*** ERROR: amb tree exhausted

このように、fail でバックトラックすることで全ての解を求めることができます。

●反復深化による水差し問題の解法

同様に、水差し問題も反復深化で解くことができます。プログラムは次のようになります。

リスト : 水差し問題の解法 (反復深化)

(define (solver-water-id limit exit goal)
  (let loop ((n 0) (path '((0 0))))
    (if (= n limit)
        (if (or (= (get-A (car path)) goal)
                (= (get-B (car path)) goal))
            (exit (reverse path))
            (fail))
        (let ((fn (amb full-A clear-A A->B full-B clear-B B->A)))
          (let ((state (fn (car path))))
            (assert (not (member state path)))
            (loop (+ n 1) (cons state path)))))))

プログラムの処理内容は経路の探索とほぼ同じです。n が limit に到達して解が見つからない場合は fail でバックトラックすることに注意してください。

それでは実行してみましょう。

gosh[r7rs.user]> (initialize-amb-fail)
()
gosh[r7rs.user]> (id-search 12 solve-water-id 4)
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
----- 8 -----
----- 9 -----
----- 10 -----
((0 0) (0 5) (5 0) (5 5) (8 2) (0 2) (2 0) (2 5) (7 0) (7 5) (8 4))
gosh[r7rs.user]> (fail)
----- 11 -----
((0 0) (0 5) (5 0) (5 5) (8 2) (0 2) (2 0) (2 5) (7 0) (7 5) (8 4) (0 4))

正常に動作していますね。

●積木の移動

最後に、積木の移動手順を求めるプログラムを作ります。

積木は赤 (red)、青 (blue)、緑 (green) の 3 種類あり、積木を置く場所は x, y, z の 3 つあります。積木は、一回にひとつしか移動できません。また、上に積木が置かれている場合も、移動することはできません。上にある積木をどかしてから移動します。左図の初期状態の場合、積木 red を場所 y か場所 z へ動かすことはできますが、積木 blue や green を動かすことはできません。

問題は、初期状態から積木をひとつずつ動かして、最終状態になるまでの移動手順を求めることです。

今回は積木をシンボル red, blue, green で、状態をリスト (x y z) で、x, y, z もリストで表すことにします。たとえば、初期状態と最終状態は次のようになります。

初期状態 : ((red blue green) () ())
最終状態 : (() () (red blue green))

積木の移動は 6 通りの方法があります。これを関数 move1 から move6 で表します。次のリストを見てください。

リスト : 積木の移動

;;; x -> y
(define (move1 state)
  (if (null? (car state))
      #f
      (list (cdr (car state))
            (cons (car (car state)) (cadr state))
            (caddr state))))

;;; x -> z
(define (move2 state)
  (if (null? (car state))
      #f
      (list (cdr (car state))
            (cadr state)
            (cons (car (car state)) (caddr state)))))

;;; y -> x
(define (move3 state)
  (if (null? (cadr state))
      #f
      (list (cons (car (cadr state)) (car state))
            (cdr (cadr state))
            (caddr state))))

;;; y -> z
(define (move4 state)
  (if (null? (cadr state))
      #f
      (list (car state)
            (cdr (cadr state))
            (cons (car (cadr state)) (caddr state)))))

;;; z -> x
(define (move5 state)
  (if (null? (caddr state))
      #f
      (list (cons (car (caddr state)) (car state))
            (cadr state)
            (cdr (caddr state)))))

;;; z -> y
(define (move6 state)
  (if (null? (caddr state))
      #f
      (list (car state)
            (cons (car (caddr state)) (cadr state))
            (cdr (caddr state)))))

たとえば、x から y へ積木を動かす move1 の場合、まず x に積木があることを確認します。空リストであれば #f を返します。積木があれば、リスト x の先頭要素を取り除き、その要素をリスト y の先頭に追加します。あとの関数も同じです。

移動手順を求める関数 solve-block は次のようになります。

リスト : 積木の移動

(define (solver-block start goal)
  (let loop ((path (list start)))
    (if (equal? (car path) goal)
        (reverse path)
      (let ((move (amb move1 move2 move3 move4 move5 move6)))
        (let ((state (move (car path))))
          (assert (and state (not (member state path))))
          (loop (cons state path)))))))

プログラムは経路の探索や水差し問題とほぼ同じです。これで幅優先探索を行う amb を使うと最短手順を求めることができます。

それでは実際に実行してみましょう。

gosh[r7rs.user]> (initialize-amb-fail)
()
gosh[r7rs.user]> (solver-block '((red blue green) () ()) '(() () (red blue green)))
(((red blue green) () ()) ((blue green) (red) ()) ((green) (blue red) ())
 (() (green blue red) ()) (() (blue red) (green)) (() (red) (blue green))
 (() () (red blue green)))

わかりやすく書き直すと次のようになります。

((red blue green) () ())
((blue green) (red) ())
((green) (blue red) ())
(() (blue red) (green))
(() (red) (blue green))
(() () (red blue green)))

5 手で解くことができました。ちなみに、深さ優先探索で解くと最初に次の手順が表示されます。

((red blue green) () ())
((blue green) (red) ())
((green) (blue red) ())
(() (green blue red) ())
(() (blue red) (green))
((blue) (red) (green))
(() (red) (blue green))
((red) () (blue green))
(() () (red blue green)))

8 手になりました。このように、探索問題は amb を使うと簡単に解くことができますが、幅優先探索の場合、問題によってはメモリを大量に消費することがあります。ご注意くださいませ。

●プログラムリスト１

リスト : 経路の探索

(import (scheme base) (mylib amb3))

;;; 隣接リスト
(define *adjacent*
  '((a b c)
    (b a c d)
    (c a b e)
    (d b e f)
    (e c d g)
    (f d)
    (g e)))

;;; 深さ優先探索
(define (depth-first-search start goal)
  (let loop ((path (list start)))
    (if (eq? (car path) goal)
        (reverse path)
        (let ((x (apply amb-f (assoc (car path) *adjacent*))))
          (assert (not (member x path)))
          (loop (cons x path))))))

(define (search limit exit start goal)
  (let loop ((n 1) (path (list start)))
    (if (= n limit)
        (if (eq? (car path) goal)
            (exit (reverse path))
            (fail))
        (let ((x (apply amb-f (assoc (car path) *adjacent*))))
          (assert (not (member x path)))
          (loop (+ n 1) (cons x path))))))

●プログラムリスト２

リスト : 水差し問題

(import (scheme base) (mylib amb3))

;;; アクセス関数
(define MAX-A 8)
(define MAX-B 5)
(define (get-A state) (car state))
(define (get-B state) (cadr state))

;;; A を満杯にする
(define (full-A state)
  (list MAX-A (get-B state)))

;;; A を空にする
(define (clear-A state)
  (list 0 (get-B state)))

;;; A -> B
(define (A->B state)
  (let ((w (min (get-A state) (- MAX-B (get-B state)))))
    (list (- (get-A state) w) (+ (get-B state) w))))

;;; B を満杯にする
(define (full-B state)
  (list (get-A state) MAX-B))

;;; B を空にする
(define (clear-B state)
  (list (get-A state) 0))

;;; B->A
(define (B->A state)
  (let ((w (min (- MAX-A (get-A state)) (get-B state))))
    (list (+ (get-A state) w) (- (get-B state) w))))

;;; amb1, amb3 は深さ優先、amb2 は幅優先になる
(define (solver-water goal)
  (let loop ((path '((0 0))))
    (if (or (= (get-A (car path)) goal)
            (= (get-B (car path)) goal))
        (reverse path)
        (let ((fn (amb full-A clear-A A->B full-B clear-B B->A)))
          (let ((state (fn (car path))))
            (assert (not (member state path)))
            (loop (cons state path)))))))

;;; 反復深化 (amb3)
(define (solver-water-id limit exit goal)
  (let loop ((n 0) (path '((0 0))))
    (if (= n limit)
        (if (or (= (get-A (car path)) goal)
                (= (get-B (car path)) goal))
            (exit (reverse path))
            (fail))
        (let ((fn (amb full-A clear-A A->B full-B clear-B B->A)))
          (let ((state (fn (car path))))
            (assert (not (member state path)))
            (loop (+ n 1) (cons state path)))))))

●プログラムリスト３

リスト : 積木の移動

(import (scheme base) (scheme cxr) (mylib amb2))

;;; x -> y
(define (move1 state)
  (if (null? (car state))
      #f
    (list (cdr (car state))
          (cons (car (car state)) (cadr state))
          (caddr state))))

;;; x -> z
(define (move2 state)
  (if (null? (car state))
      #f
    (list (cdr (car state))
          (cadr state)
          (cons (car (car state)) (caddr state)))))

;;; y -> x
(define (move3 state)
  (if (null? (cadr state))
      #f
    (list (cons (car (cadr state)) (car state))
          (cdr (cadr state))
          (caddr state))))

;;; y -> z
(define (move4 state)
  (if (null? (cadr state))
      #f
    (list (car state)
          (cdr (cadr state))
          (cons (car (cadr state)) (caddr state)))))

;;; z -> x
(define (move5 state)
  (if (null? (caddr state))
      #f
    (list (cons (car (caddr state)) (car state))
          (cadr state)
          (cdr (caddr state)))))

;;; z -> y
(define (move6 state)
  (if (null? (caddr state))
      #f
    (list (car state)
          (cons (car (caddr state)) (cadr state))
          (cdr (caddr state)))))


(define (solver-block start goal)
  (let loop ((path (list start)))
    (if (equal? (car path) goal)
        (reverse path)
        (let ((move (amb move1 move2 move3 move4 move5 move6)))
          (let ((state (move (car path))))
            (assert (and state (not (member state path))))
            (loop (cons state path)))))))