SICP 読み (208) 4.3.2 非決定性プログラムの例

直前エントリで 8queen なソレが云々ってコトで、以前書いた手続きなエントリを探して中身を見てみる。問題 2.42 の解は以下な模様。

(define (filter predicate sequence)
  (cond ((null? sequence) '())
	((predicate (car sequence))
	 (cons (car sequence)
	       (filter predicate (cdr sequence))))
	(else
	 (filter predicate (cdr sequence)))))

(define (accumulate op init seq)
  (if (null? seq)
      init
      (op (car seq)
	  (accumulate op init (cdr seq)))))

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))

(define (enumulate-interval low high)
  (if (> low high)
      '()
      (cons low (enumulate-interval (+ low 1) high))))

(define (queens board-size)
  (define (queen-cols k)
    (if (= k 0)
	(list empty-board)
	(filter
	 (lambda (positions) (safe? k positions))
	 (flatmap
	  (lambda (rest-of-queens)
	    (map (lambda (new-row)
		   (adjoin-position new-row k rest-of-queens))
		 (enumulate-interval 1 board-size)))
	  (queen-cols (- k 1))))))
  (queen-cols board-size))

(define empty-board '(()))

(define (tailend seq)
  (let f ((seq seq) (ret '()))
    (if (null? seq)
	ret
	(f (cdr seq) (car seq)))))

(define (safe? k seq)
  (define (safe-iter p k seq)
    (cond ((= (- k p) 0) #t)
	  ((= (abs (- (car seq) (tailend seq))) (- k p)) #f)
	  ((= (car seq) (tailend seq)) #f)
	  (else
	   (safe-iter (+ p 1) k (cdr seq)))))
  (safe-iter 1 k seq))

(define (adjoin-position new-row k seq)
  (if (= k 1)
      (list new-row)
      (append seq (list new-row))))

リハビリ必要。ざっくり処理をトレイスしてみる。例えば (queens 8) で手続きが呼ばれると、(queen-cols 0) まで再帰が進む。0 の時は '(()) が戻って flatmap は '((1) (2) (3) (4) (5) (6) (7) (8)) を戻してそれぞれの要素に filter をかける。ここでは safe? に渡す k は 1 なんでオールセイフ。flatmap が戻したリストがそのまま戻る。
次に戻ったリストのそれぞれの要素について例えば '(1) を '((1 1) (1 2) (1 3) (1 4) (1 5) (1 6) (1 7) (1 8)) にしていきつつ flatmap する。
むむ。filter な手続きが若干微妙。自分で作っといて何だろうな。後天性記憶障害が日に日に重くなってる感満点やっさ。あ、ケツに追加してってるからケツだけ見るのか。ってか、これって使えそうだなぁ。同じ方式でリスト作って distinct? で filter すれば良さげに見えるんですが (baker (amb 1 2 3 4 5)) なソレ、という部分は微妙??
昨晩エントリなソレではリストのリストを渡す形にしている。一応 multiple-dwelling 手続きでは 1 から 5 が固定なんで無理矢理でっち上げてみる。

(define (filter predicate sequence)
  (cond ((null? sequence) '())
	((predicate (car sequence))
	 (cons (car sequence)
	       (filter predicate (cdr sequence))))
	(else (filter predicate (cdr sequence)))))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
	  (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))

(define (distinct? items)
  (cond ((null? items) #t)
	((null? (cdr items)) #t)
	((member (car items) (cdr items)) #f)
	(else (distinct? (cdr items)))))

(define (multiple-dwelling-filter l)
  (define baker (car l))
  (define cooper (cadr l))
  (define fletcher (caddr l))
  (define miller (cadddr l))
  (define smith (car (cddddr l)))
  (and (distinct? l)
       (not (= baker 5))
       (not (= cooper 1))
       (not (= fletcher 5))
       (not (= fletcher 1))
       (> miller cooper)
       (not (= (abs (- smith fletcher)) 1))
       (not (= (abs (- fletcher cooper)) 1))))

(define (multiple-dwelling-filter-2 l)
  (define baker (car l))
  (define cooper (cadr l))
  (define fletcher (caddr l))
  (define miller (cadddr l))
  (define smith (car (cddddr l)))
  (and (distinct? l)
       (not (= baker 5))
       (not (= cooper 1))
       (not (= fletcher 5))
       (not (= fletcher 1))
       (> miller cooper)
       (not (= (abs (- fletcher cooper)) 1))))


;    (require
;     (distinct? (list baker cooper fletcher miller smith)))
;    (require (not (= baker 5)))
;    (require (not (= cooper 1)))
;    (require (not (= fletcher 5)))
;    (require (not (= fletcher 1)))
;    (require (> miller cooper))
;    (require (not (= (abs (- smith fletcher)) 1)))
;    (require (not (= (abs (- fletcher cooper)) 1)))


(define (enumulate-interval low high)
  (if (> low high)
      '()
      (cons low (enumulate-interval (+ low 1) high))))

(define empty-board '(()))

(define (adjoin-position new-row k seq)
  (if (= k 1)
      (list new-row)
      (append seq (list new-row))))

(define (test-enum)
  (let ((board-size 5))
    (define (test-enum-iter k)
      (if (= k 0)
	  (list empty-board)
	  (filter
	   (lambda (positions) (distinct? positions))
	   (flatmap
	    (lambda (rest-of-queens)
	      (map (lambda (new-row)
		     (adjoin-position new-row k rest-of-queens))
		   (enumulate-interval 1 board-size)))
	    (test-enum-iter (- k 1))))))
    (test-enum-iter board-size)))

以下が試験。

#!/usr/bin/env gosh

(use test.unit)
(require "4.41")

(define-test-suite "4.41"

  ("part-1"
   ("length"
    (assert-equal 120 (length (test-enum)))
    )

   ("example"
    (assert-equal '((3 2 4 5 1)) (filter multiple-dwelling-filter (test-enum)))
    )

   ("example (2)"
;    (assert-equal '((3 2 4 5 1)
;		    (1 2 4 3 5)
;		    (1 2 4 5 3))
    (assert-equal '((1 2 4 3 5)
		    (1 2 4 5 3)
		    (1 4 2 5 3)
		    (3 2 4 5 1)
		    (3 4 2 5 1))
		  (filter multiple-dwelling-filter-2 (test-enum)))
    )
   )
  )

最初にヒネり出した手続きよりは早い。多分数え上げな手続きに 4.40 なナニを盛り込んだらもっと効率が良くなるはず。でも盛り込みは不可能な気もする。