エイトクイーンパズル

途中の問題は後であげますね。面倒くさくてｗ

問題 2.42
みんな大好きエイトクイーンパズル！

(define nil '())

(define (fold-right op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

(define (accumulate op initial sequence)
  (fold-right op initial sequence))

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

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

;;;;;

(define (queens board-size)
  (define empty-board nil)
  
  (define (generate-unsafe-positions position k)
    (let ((r (car position))
          (c (cadr position)))
      (define (iter i unsafe-positions)
        (if (= i k)
            (filter (lambda (p) (and (>= (car p) 1)
                                     (<= (car p) board-size)
                                     (<= (cadr p) board-size))) unsafe-positions)
            (iter (+ i 1) (append unsafe-positions
                                  (list (list r (+ c i))
                                        (list (+ r i) (+ c i))
                                        (list (- r i) (+ c i)))))))
      (iter 1 nil)))
  
  (define (contains-unsafe-position? positions unsafe-positions)
    (define (iter us-pos)
      (if (null? us-pos)
          #f
          (if (not (null? (filter (lambda (pos) (and (= (car pos) (car (car us-pos)))
                                                     (= (cadr pos) (cadr (car us-pos)))))
                                  positions)))
              #t
              (iter (cdr us-pos)))))
    (iter unsafe-positions))
  
  (define (safe? k positions)
    (let ((unsafe-positions (flatmap (lambda (p) (generate-unsafe-positions p k)) positions)))
      (not (contains-unsafe-position? positions unsafe-positions))))
  
  (define (adjoin-position new-row k rest-of-queens)
    (append rest-of-queens (list (list new-row k))))
  
  (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))))))
  (queen-cols board-size))

generate-unsafe-positions 手続きは、置き方リスト１パターン分からクイーンを置いてはいけない位置リストを生成します。生成した位置が番からはみ出しても気にせずにとりあえずリストに追加し、最後に番からはみ出した分はフィルタして取り除きます。また、置き方リスト１パターン分の最後のクイーン分(k番目)は処理しなくて良いので、終了判定は i > k ではなくて i = k となります。

contains-unsafe-position? 手続きは、positions 内に unsafe-positions を含むか検査します。手続き名にハテナが付いているとおり、含む場合は真値を、含まない場合は偽値を返します。

safe? 手続きは配置パターン１つぶんについて置いてはいけないパターンを含むか検査し、含まない場合は真値を、含む場合は偽値を返します。

実行結果

gosh> (queens 4)
(((2 1) (4 2) (1 3) (3 4)) ((3 1) (1 2) (4 3) (2 4)))

4x4 でテスト。大丈夫そう。

gosh> (queens 8)
(((1 1) (5 2) (8 3) (6 4) (3 5) (7 6) (2 7) (4 8))
 ((1 1) (6 2) (8 3) (3 4) (7 5) (4 6) (2 7) (5 8))
 ((1 1) (7 2) (4 3) (6 4) (8 5) (2 6) (5 7) (3 8))
 ((1 1) (7 2) (5 3) (8 4) (2 5) (4 6) (6 7) (3 8))
 ((2 1) (4 2) (6 3) (8 4) (3 5) (1 6) (7 7) (5 8))
 ((2 1) (5 2) (7 3) (1 4) (3 5) (8 6) (6 7) (4 8))
 ((2 1) (5 2) (7 3) (4 4) (1 5) (8 6) (6 7) (3 8))
...

置き方はたくさんあるので最初のほうだけ載せます。