breadth-first-search.ss

(define (breadth-first-search n)
  (let search ((lst (node-expand n '())) (solution '()))
    (if (null? lst)
	solution
	(let ((x (car lst)) (y (cdr lst)))
	  (search (if (and (safe? x) (not (goal? x n)))
		      (append y (node-expand n x))
		      y)
		  (if (and (safe? x) (goal? x n))
		      (cons x solution)
		      solution))))))

farmer-wolf-goat-and-cabbage.ss

;;;; 農夫と狼と山羊とキャベツの問題

;;;; ある河の北岸に農夫、狼、山羊がいて、そしてキャベツがある。
;;;; 農夫は、狼と山羊、キャベツを南岸に移したい。
;;;; 小舟が一隻あり、漕ぎ手の農夫以外には高々一匹(個)しか
;;;; 乗せて漕ぐことしかできない。農夫がいないとき、岸に山羊と狼
;;;; を一緒にすることはできない。また、農夫がいないとき、岸に
;;;; 山羊とキャベツを一緒にすることはできない。どのように船を
;;;; 運航したらよいのだろうか。

;;;; 北岸を n 、南岸を s によって表し、(f w g c)
;;;; というリストによって現在の状態を表すことにする。
;;;; なお、f、w、g、cはそれぞれ農夫(farmer)、狼(wolf)、
;;;; 山羊(goat)、キャベツ(cabbage)を表す。
;;;; 初期状態は(n n n n)であり、目標状態は(s s s s)である。
;;;; 船の使い方は以下の4通りがある。
;;;; ・農夫が狼と一緒に河を渡る。
;;;; ・農夫が山羊と一緒に河を渡る。
;;;; ・農夫がキャベツを一緒に河を渡る。
;;;; ・農夫が1人で河を渡る。

;;; 状態 state のもとから船を運航することで得られる
;;; 新しい状態を生成する手続き

;; (expand '(s s n n)) ==> ((n s n n) (n n n n))

(define (expand state)
  (let ((f (first state)) (w (second state))
        (g (third state)) (c (fourth state))
        (opposite (lambda (x) (if (eq? x 'n) 's 'n))))
    (append
     (if (eq? f w) `((,(opposite f) ,(opposite w) ,g ,c)) '())
     (if (eq? f g) `((,(opposite f) ,w ,(opposite g) ,c)) '())
     (if (eq? f c) `((,(opposite f) ,w ,g ,(opposite c))) '())
     `((,(opposite f) ,w ,g ,c)))))

;;; 状態(f w g c)において安全であるかどうかを判定する述語

;; (safe? '(s n s n)) ==> #t

(define (safe? state)
  (let ((f (first state)) (w (second state))
	(g (third state)) (c (fourth state)))
    (not (or (and (eq? w g) (not (eq? f w)))
	     (and (eq? g c) (not (eq? f g)))))))

;;; 目標状態であるかどうかの判定

(define (goal? state)
  (let ((f (first state)) (w (second state))
	(g (third state)) (c (fourth state)))
    (and (eq? f w) (eq? w g) (eq? g c))))

;;; 節点の展開を行う手続き

;; (node-expand '(n s n s) '((s s n s))) ==> ((s s s s))

(define (node-expand state hist)
  (let loop ((lst (expand state)) (nlst '()))
    (if (null? lst)
	nlst
	(let ((z (car lst)))
	  (loop (cdr lst) (if (member z hist)
			      nlst
			      (cons z nlst)))))))

(define (depth-first-search init)
  (let search ((lst (node-expand init '())) (closed `(,init)))
    (if (null? lst)
	(reverse closed)
	(let ((x (car lst)) (y (cdr lst)))
	  (let ((c (cons x closed)))
	    (search (cond ((goal? x)
			   '())
			  ((safe? x)
			   (append (node-expand x c) y))
			  (else
			   y))
		    (if (safe? x)
			c
			closed)))))))

;; ;; 実行例
;; > (depth-first-search '(n n n n))
;; ((n n n n)
;;  (s n s n)
;;  (n n s n)
;;  (s n s s)
;;  (n n n s)
;;  (s s n s)
;;  (n s n s)
;;  (s s s s))
;; > 

nqueen.ss

;;;; Nクイーン問題とは、N x N のチェス盤に N 個のクイーンを互いに取られ
;;;; ないように配置する問題のことをいう。
;;;; クイーンが互いにとられない配置にあるとき安全であるとよぶことにする。
;;;; なかでも8(エイト)クイーン問題とよばれる、N = 8 の場合が有名である。

;;; 節点を展開する手続き

;; (node-expand 4 '(4)) ==> ((4 4) (3 4) (2 4) (1 4))

(define (node-expand n lst)
  (let loop ((n n) (acc '()))
    (if (zero? n)
	(reverse acc)
	(loop (- n 1) (cons (cons n lst) acc)))))

;;; リスト (qi … q8) が安全であるかどうかを判定する述語

;; (safe? '(1 4 2)) ==> #t
;; (safe? '(3 4 2)) ==> #f

(define (safe? lst)
  (let ((new (car lst))
	(hlst (cdr lst)))
    (or (null? hlst)
	(safe-aux? new (+ new 1) (- new 1) hlst))))

(define (safe-aux? new up down hlst)
  (or (null? hlst)
      (let ((pos (car hlst)))
	(and (call/cc
	      (lambda (k)
		(for-each (lambda (x)
			    (let ((it (not (= pos x))))
			      (if it it (k it))))
			  `(,new ,up ,down))))
	     (safe-aux? new (+ up 1) (- down 1)
			(cdr hlst))))))

;;; 生成された解候補が解であるかどうかを判定する述語

(define (goal? x n) (= (length x) n))

;;; 深さ優先探索の手続き

(define (depth-first-search n)
  (let search ((lst (node-expand n '())) (solution '()))
    (if (null? lst)
	solution
	(let ((x (car lst)) (y (cdr lst)))
;; 	  (for-each display `(,"lst = " ,y ," x = " ,x))
;; 	  (newline)
	  (search (if (and (safe? x) (not (goal? x n)))
		      (append (node-expand n x) y)
		      y)
		  (if (and (safe? x) (goal? x n))
		      (cons x solution)
		      solution))))))

;; ;; 実行例
;; > (depth-first-search 4)
;; ((3 1 4 2) (2 4 1 3))
;; > (depth-first-search 6)
;; ((5 3 1 6 4 2) (4 1 5 2 6 3) (3 6 2 5 1 4) (2 4 6 1 3 5))
;; > (length (depth-first-search 8))
;; 92
;; >