sec-2.2.3 (c) マップのネスト

この場合、 (list nil) というひとつの項目からなる列、つまり空集合を生成します。
For this, we generate (list nil), which is a sequence with one item, namely the set with no elements.

「この場合、 (list nil) というひとつの項目、すなわち空集合、からなる列を生成します。」かな？^^;

sec-2.2.3 (c) 実装

; [sec-2.2.3-c.scm]
;
(define (sec-2.2.3-c)
	(print "(gen-pairs 6)")
	(print ";==> " (gen-pairs 6))

	(newline)
	(print "(prime-sum-pairs 6)")
	(print ";==> " (prime-sum-pairs 6))

	(newline)
	(print "(permutations (list 1 2 3))")
	(print ";==> " (permutations (list 1 2 3)))
	#t)


; {{{ 準備.
(define accumulate fold-right)
(define nil ())

(define (enumerate-interval low high)
	(if
		(> low high)
		nil
		(cons low (enumerate-interval (+ low 1) high))))

(define (prime? n)
	(define (iter i n)
		(cond
			((> (* i i) n) #t)
			((= (remainder n i) 0) #f)
			(else (iter (+ i 1) n))))
	(if
		(< n 2)
		#f
		(iter 2 n)))
; }}} 準備.


(define (gen-pairs n)
	(accumulate
		append
		nil
		(map
			(lambda (i)
				(map
					(lambda (j) (list i j))
					(enumerate-interval 1 (- i 1))))
			(enumerate-interval 1 n))))


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


(define (prime-sum? pair)
	(prime? (+ (car pair) (cadr pair))))


(define (make-pair-sum pair)
	(list (car pair) (cadr pair) (+ (car pair) (cadr pair))))


(define (prime-sum-pairs n)
	(map
		make-pair-sum ; (Int, Int) -> (Int, Int, Int)
		(filter
			prime-sum?
			(flatmap        ;==> [(i:Int, j:Int)]     ; concatenated.
				(lambda (i) ; i:Int -> [(i:Int, j:Int)]
					(map
						(lambda (j) (list i j)) ; j:Int -> (i:Int, j:Int)
						(enumerate-interval 1 (- i 1)))) ; [j:Int]
				(enumerate-interval 1 n))))) ; [Int]


(define (permutations s)
	(if
		(null? s)  ; 集合は空か?
		(list nil) ; 空の場合は空集合を持つ列が復帰値.
		(flatmap
			(lambda (x)
				(map
					(lambda (p) (cons x p))
					(permutations (remove x s))))
			s)))


(define (remove item sequence)
	(filter
		(lambda (x) (not (= x item)))
		sequence))

sec-2.2.3 (c) 実行結果

gosh> (sec-2.2.3-c)
(gen-pairs 6)
;==> ((2 1) (3 1) (3 2) (4 1) (4 2) (4 3) (5 1) (5 2) (5 3) (5 4) (6 1) (6 2) (6 3) (6 4) (6 5))

(prime-sum-pairs 6)
;==> ((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11))

(permutations (list 1 2 3))
;==> ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))

ex-2.40. unique-pairs

1 ≤ j < i ≤ n な (i, j) の組の列.

ex-2.40 実装

; [ex-2.40.scm]]
;
(define (ex-2.40)
	(print "(unique-pairs 6)")
	(print ";==> " (unique-pairs 6))

	(newline)
	(print "(prime-sum-pairs-2.40 6)")
	(print ";==> " (prime-sum-pairs-2.40 6))
	#t)


(load "./sec-2.2.3-c") ; flatmap, prime-sum?, enumerate-interval.


(define (unique-pairs n)
	(flatmap
		(lambda (i)
			(map
				(lambda (j)
					(list i j))
				(enumerate-interval 1 (- i 1))))
		(enumerate-interval 1 n)))


(define (prime-sum-pairs-2.40 n)
	(map
		make-pair-sum
		(filter prime-sum? (unique-pairs n))))

ex-2.40 実行結果

gosh> (ex-2.40)
(unique-pairs 6)
;==> ((2 1) (3 1) (3 2) (4 1) (4 2) (4 3) (5 1) (5 2) (5 3) (5 4) (6 1) (6 2) (6 3) (6 4) (6 5))

(prime-sum-pairs-2.40 6)
;==> ((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11))

ex-2.41. 特定の合計数になる3つ組

「合計で s になる」の部分若干わすれてたっ（）

ex-2.41 実装

; [ex-2.41.scm]
;
(define (ex-2.41)
	(print "(unique-triples 5)")
	(print ";==> " (unique-triples 5))
	(print "(const-sum-pairs 10)")
	(print ";==> " (const-sum-pairs 10))
	#t)


(load "./sec-2.2.3-c") ; accumulate, flatmap, prime-sum?, enumerate-interval.


(define (const-sum-pairs s)
	(filter
		(lambda (triple) ; (i,j,k) -> Bool
			(let
				(
					(sum (+ (list-ref triple 0) (list-ref triple 1) (list-ref triple 2)))
				)
				(= sum s)))
		(unique-triples s))) ; [(i,j,k)]

(define (unique-triples n)
	(flatmap
		(lambda (i)
			(flatmap
				(lambda (j)
					(map
						(lambda (k)
							(list i j k))
						(enumerate-interval 1 (- j 1))))
				(enumerate-interval 1 (- i 1))))
		(enumerate-interval 1 n)))

ex-2.41 実行結果

gosh> (ex-2.41)
(unique-triples 5)
;==> ((3 2 1) (4 2 1) (4 3 1) (4 3 2) (5 2 1) (5 3 1) (5 3 2) (5 4 1) (5 4 2) (5 4 3))
(const-sum-pairs 10)
;==> ((5 3 2) (5 4 1) (6 3 1) (7 2 1))

ex-2.42 8 Queens

ひとまず最低限動作に必要な部分を実装.
今はまだ全部が safe としておく.
つまり (queen n) を実行すると全部の組み合わせが解として返る.

(define empty-board nil)
(define (safe? k positions)
	#t)
(define (adjoin-position new-row k rest-of-queens)
	(cons new-row rest-of-queens))

queen の利き筋は斜めと縦横で, その線上にいる場合に unsafe になる.
逆に, 新しく置いた queen から見て, 斜め左上, 真上, 斜め右上のいずれかに既に queen がいる場合にのみ unsafe と判断できる.
この3方向の判定をそれぞれ safe-left?, safe-column?, safe-right? とおく.

(define (safe? k positions)
	(and
		(safe-left? k (car positions) (cdr positions))
		(safe-column? k (car positions) (cdr positions))
		(safe-right? (+ k 1) (car positions) (cdr positions))))

(define (safe-left? k positions)
	#t)
(define (safe-column? k positions)
	#t)
(define (safe-right? k positions)
	#t)

(queens 1)
;==> ((1))

(queens 2)
;==> ((1 1) (2 1) (1 2) (2 2))

(queens 3)
;==> ((1 1 1) (2 1 1) (3 1 1) (1 2 1) (2 2 1) (3 2 1) (1 3 1) (2 3 1) (3 3 1)
(1 1 2) (2 1 2) (3 1 2) (1 2 2) (2 2 2) (3 2 2) (1 3 2) (2 3 2) (3 3 2)
(1 1 3) (2 1 3) (3 1 3) (1 2 3) (2 2 3) (3 2 3) (1 3 3) (2 3 3) (3 3 3))

safe-column? を実装する.
ぐぐっと safe が減少.

(define (safe-column? k p positions)
	(cond
		((null? positions) #t)
		((= (car positions) p) #f)
		(else (safe-column? k p (cdr positions)))))

(queens 1)
;==> ((1))

(queens 2)
;==> ((2 1) (1 2))

(queens 3)
;==> ((3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3))
#t

safe-left? を実装.
一段上に遡るたびに queen さんがいるかの判定する場所も1つずれていく.

(define (safe-left? k p positions)
	(cond
		((null? positions) #t)
		((= (car positions) (- p 1)) #f)
		(else (safe-left? k (- p 1) (cdr positions)))))

(queens 1)
;==> ((1))

(queens 2)
;==> ((1 2))

(queens 3)
;==> ((2 3 1) (3 1 2) (1 2 3))

safe-right? も実装:

(define (safe-right? k p positions)
	(cond
		((null? positions) #t)
		((= (car positions) (+ p 1)) #f)
		(else (safe-right? k (+ p 1) (cdr positions)))))

(queens 1)
;==> ((1))

(queens 2)
;==> ()

(queens 3)
;==> ()

safe? のなかで k 使ってない＼(^o^)／
盤面を右とか左に突き抜けちゃうけど計算量以外は問題ないはず？^^;

1 から 10 の解の数:

(for-each (lambda (n) (print (list n (length (queens n))))) (enumerate-interval 1 10))
;==>
(1 1)
(2 0)
(3 0)
(4 2)
(5 10)
(6 4)
(7 40)
(8 92)
(9 352)
(10 724)

ex-2.42 実装

; [ex-2.42.scm]
;
(define (ex-2.42)
	(print "(queens 1)")
	(print ";==> " (queens 1))

	(newline)
	(print "(queens 2)")
	(print ";==> " (queens 2))

	(newline)
	(print "(queens 3)")
	(print ";==> " (queens 3))
	#t)


(load "./sec-2.2.3-c")


(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))
							(enumerate-interval 1 board-size)))
					(queen-cols (- k 1))))))

	(define empty-board nil)
	(define (safe? k positions)
		(and
			(safe-left? k (car positions) (cdr positions))
			(safe-column? k (car positions) (cdr positions))
			(safe-right? (+ k 1) (car positions) (cdr positions))))
	(define (safe-left? k p positions)
		(cond
			((null? positions) #t)
			((= (car positions) (- p 1)) #f)
			(else (safe-left? k (- p 1) (cdr positions)))))
	(define (safe-column? k p positions)
		(cond
			((null? positions) #t)
			((= (car positions) p) #f)
			(else (safe-column? k p (cdr positions)))))
	(define (safe-right? k p positions)
		(cond
			((null? positions) #t)
			((= (car positions) (+ p 1)) #f)
			(else (safe-right? k (+ p 1) (cdr positions)))))
	(define (adjoin-position new-row k rest-of-queens)
		(cons new-row rest-of-queens))
	(queen-cols board-size))

ex-2.42 実行結果

gosh> (ex-2.42)
(queens 1)
;==> ((1))

(queens 2)
;==> ()

(queens 3)
;==> ()

ex-2.43

本来は board-size 回, 自分に必要な盤面を1回だけ呼べばよかったのが,
board-size 回, さらに board-size 回再計算してしまっているため.

O(n) が O(n^2) になっていることから,
T^2 の時間が必要になると見積もれる.