Top / Scheme部会 / ネタ / pass-river

家族の渡河問題

いわゆる「宣教師と土人」問題の1バリエーション。

#!/usr/local/bin/gosh

;;;===================================================================
;;; pass-river
;;;
;;;  父, 母, 召使, 息子2人, 娘2人, 犬 が
;;;  ボートで川を渡れるかどうかを調べるプログラム。
;;;
;;;  川を渡るときに、いずれの状態のいずれの場所に於いても、
;;;  以下の制約条件がある。
;;;
;;;    父がいない場所で、母と息子は共存できない。
;;;    母がいない場所で、父と娘は共存できない。
;;;    召使がいない場所で、犬と父、母、息子、娘は共存できない。
;;;
;;;  また、ボートに関して以下の制約条件がある。
;;;
;;;    ボートを操縦できるのは父、母、召使のみ。
;;;    ボートの定員は2名
;;;
;;;  川俣吉広,      2003年7月30日 / 記述言語 Scheme
;;;
;;;  (オリジナル版: 2000年6月12日 / 記述言語 EmacsLisp)
;;;
;;;===================================================================

;;
;; 全域変数
;;
(define snapshot-printf-flag #f) ; デバッグ出力の制御
(define tries 0)                 ;  試行回数

;;
;; メイン関数
;;
(define (pass-river trace-flag)
  (set! snapshot-printf-flag trace-flag)
    ;;
    ;; 初期状態の引数で実行開始
    (move-stat 0
	       "→"
	       '(父 母 召使 長男 次男 長女 次女 犬)
	       '()
	       '()
	       '(((左岸) (ボート 右岸)))) ; These sentinels will never apppear.
    "全試行終了")

(define (move-stat n d l b r h)
  (set! tries (+ tries 1))
  ;;
  ;; 状態の表示
  (snapshot-printf #f "~6@d, ~4@d : ~a ~a ~a ~a ~a" tries n l d b d r)
  ;;
  ;; 状態の検査と遷移
  (cond
					; 遷移終了: 全員右岸に移った
   ((not (or (pair? l) (pair? b)))
    (snapshot-printf #f " : ~d手目で解決!\n" n)
    (print-history (cons (list l (cons d r)) h)))
					; 遷移中止: 左岸が制約条件を満たしていない
   ((check-restriction l)
    (snapshot-printf #f " : 左岸が制約違反\n"))
					; 遷移中止: ボートが制約条件を満たしていない
   ((and (not (null? b))
	 (check-boat-restriction b))
    (snapshot-printf #f " : ボートが制約違反\n"))
					; 遷移中止: 右岸が束縛条件を満たしていない
   ((check-restriction r)
    (snapshot-printf #f " : 右岸が制約違反\n"))
					; 遷移中止: 段階の数が深すぎる
   ((< 34 n)
    (snapshot-printf #f " : 試行段数深すぎ\n"))
					; 履歴の検査
   ((and (null? b) (check-history (cons d r) h))
    (snapshot-printf #f " : 試行済の組合せ\n"))
   ;;
   ;; 条件を満たしていたので遷移する。
   ;;
					; ボートにだれか乗っていた場合
   ((pair? b)
    (snapshot-printf #f "\n")
					; 乗員を進行方向の岸に移す
    (if (equal? d "→")
	(move-stat (+ n 1) (flip-boat-dir d) l '() (append b r) h)
	(move-stat (+ n 1) (flip-boat-dir d) (append l b) '() r h)))
					; 全員が岸にいる場合
   (else
    (snapshot-printf #f "\n")
					; 出発する岸から任意の一人又は二人の組合せを選んで、
					; 次の状態に遷移
    (cond ((equal? d "→")
	   (map (lambda (e)
		  (move-stat (+ n 1) d (rest-of-elements e l) e r (cons (list l (cons d r)) h)))
		(get-any-combination l)))
	  (else
	   (map (lambda (e)
		  (move-stat (+ n 1) d l e (rest-of-elements e r) (cons (list l (cons d r)) h)))
		(get-any-combination r)))))))

;; デバッグ用出力
;; 変数forcedが #f でない場合、出力制御フラグ
;; snapshot-printf-flagの値に関わらず
;; 出力が行われる。
;;
(define (snapshot-printf forced . l)
  (if (or forced
          snapshot-printf-flag)
      (display (apply format l))))

;; 履歴の表示
;;
(define (print-history l)
					; 補助関数
  (define (print-history-sub l)
    (if (null? l)
	(snapshot-printf #t "----------\n")
	(begin (print-history-sub (cdr l))
	       (snapshot-printf #t "~35A ~A ~A\n" (caar l) (car (cadar l)) (cdr (cadar l))))))
  (print-history-sub l)
  (snapshot-printf #t "==========\n"))

;; 履歴の検査
;;
(define (check-history r h)
  (if (pair? h)
      (if (same-element? r (cadar h))
          #t
	  (check-history r (cdr h)))
      #f))

;; 制約条件の検査
;;   制約を満たしている場合に #f
;;   そうでない場合に non #f を返す
;;
(define (check-restriction l)
  (or (and (member '父 l)
           (not (member '母 l))
           (or (member '長女 l)
               (member '次女 l)))
      (and (member '母 l)
           (not (member '父 l))
           (or (member '長男 l)
               (member '次男 l)))
      (and (member '犬 l)
           (not (member '召使 l))
           (or (member '父 l)
               (member '母 l)
               (member '長男 l)
               (member '次男 l)
               (member '長女 l)
               (member '次女 l)))))

;; ボート上の制約条件の検査
;;   通常の制約条件に加えて
;;   ボートの操縦が可能かどうかの検査が
;;   追加されている
;;
(define (check-boat-restriction l)
  (or (check-restriction l)
      (not (or (member '父 l)
               (member '母 l)
               (member '召使 l)))))

;; ボートの進行方向を反転した状態を返す
;;
(define (flip-boat-dir s)
  (if (equal? s "→")
      "←"
      "→"))

;; リストlの要素から、1つあるいは2つの要素を取り出した
;; 可能な全ての場合を要素として持つリストを返す。
;;
(define (get-any-combination l)
  (if (pair? l)
      (append (cons (list (car l))
                    (map (lambda (e) (list (car l) e))
			 (cdr l)))
              (get-any-combination (cdr l)))
      ()))

;; リストlからリストrの要素を抜いたリストを返す。
;;
(define (rest-of-elements r l)
  (if (pair? l)
      (if (member (car l) r)
          (rest-of-elements r (cdr l))
	  (cons (car l) (rest-of-elements r (cdr l))))
      ()))

;; リストl1とリストl2が同じ要素を持つかどうかを判定する。
;; 要素の順番は不定でよいが、重複した要素が存在する
;; 場合については考慮されていない。
;;
(define (same-element? l1 l2)
					; 補助関数
  (define (same-element?-sub l1 l2)
    (if (pair? l1)
	(and (member (car l1) l2)
	     (same-element?-sub (cdr l1) l2))
	#t))
  (if (not (equal? (length l1)
		   (length l2)))
      #f
      (same-element?-sub l1 l2)))

;;;===================================================================

(pass-river #t)

Top / Scheme部会 / ネタ / pass-river

トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS
Last-modified: 2009-11-28 (土) 20:02:17 (2912d)