Scheme中如何解决N-Queens？
Posted
技术标签:
【中文标题】Scheme中如何解决N-Queens？【英文标题】：How to Solve N-Queens in Scheme? 【发布时间】：2010-04-07 19:02:16 【问题描述】：我卡在扩展 exercise 28.2 of How to Design Programs 上。我使用真值或假值的向量来表示板，而不是使用列表。这是我所拥有的，但不起作用：
#lang Scheme
(define-struct posn (i j))
;takes in a position in i, j form and a board and
; returns a natural number that represents the position in index form
;example for board xxx
; xxx
; xxx
;(0, 1) -> 1
;(2, 1) -> 7
(define (board-ref a-posn a-board)
(+ (* (sqrt (vector-length a-board)) (posn-i a-posn))
(posn-j a-posn)))
;reverse of the above function
;1 -> (0, 1)
;7 -> (2, 1)
(define (get-posn n a-board)
(local ((define board-length (sqrt (vector-length a-board))))
(make-posn (floor (/ n board-length))
(remainder n board-length))))
;determines if posn1 threatens posn2
;true if they are on the same row/column/diagonal
(define (threatened? posn1 posn2)
(cond
((= (posn-i posn1) (posn-i posn2)) #t)
((= (posn-j posn1) (posn-j posn2)) #t)
((= (abs (- (posn-i posn1)
(posn-i posn2)))
(abs (- (posn-j posn1)
(posn-j posn2)))) #t)
(else #f)))
;returns a list of positions that are not threatened or occupied by queens
;basically any position with the value true
(define (get-available-posn a-board)
(local ((define (get-ava index)
(cond
((= index (vector-length a-board)) '())
((vector-ref a-board index)
(cons index (get-ava (add1 index))))
(else (get-ava (add1 index))))))
(get-ava 0)))
;consume a position in the form of a natural number and a board
;returns a board after placing a queen on the position of the board
(define (place n a-board)
(local ((define (foo x)
(cond
((not (board-ref (get-posn x a-board) a-board)) #f)
((threatened? (get-posn x a-board) (get-posn n a-board)) #f)
(else #t))))
(build-vector (vector-length a-board) foo)))
;consume a list of positions in the form of natural numbers, and a board
;returns a list of boards after placing queens on each of the positions
; on the board
(define (place/list alop a-board)
(cond
((empty? alop) '())
(else (cons (place (first alop) a-board)
(place/list (rest alop) a-board)))))
;returns a possible board after placing n queens on a-board
;returns false if impossible
(define (placement n a-board)
(cond
((zero? n) a-board)
(else (local ((define available-posn (get-available-posn a-board)))
(cond
((empty? available-posn) #f)
(else (or (placement (sub1 n)
(place (first available-posn) a-board))
(placement/list (sub1 n)
(place/list (rest available-posn) a-board)))))))))
;returns a possible board after placing n queens on a list of boards
;returns false if all the boards are not valid
(define (placement/list n boards)
(cond
((empty? boards) #f)
((zero? n) (first boards))
((not (boolean? (placement n (first boards)))) (first boards))
(else (placement/list n (rest boards)))))
【问题讨论】：
你应该发帖到PLT讨论列表：plt-scheme.org/maillist 【参考方案1】：这不是最快的方案实现，但非常简洁。我确实独立提出了它，但我怀疑它是独一无二的。它在 PLT Scheme 中，因此需要更改一些函数名称才能使其在 R6RS 中运行。解决方案列表和每个解决方案都是用 cons 构建的，因此它们是相反的。最后的反转和映射重新排序所有内容并将行添加到解决方案以获得漂亮的输出。大多数语言都有折叠类型功能，见：http://en.wikipedia.org/wiki/Fold_%28higher-order_function%29
#lang scheme/base
(define (N-Queens N)
(define (attacks? delta-row column solution)
(and (not (null? solution))
(or (= delta-row (abs (- column (car solution))))
(attacks? (add1 delta-row) column (cdr solution)))))
(define (next-queen safe-columns solution solutions)
(if (null? safe-columns)
(cons solution solutions)
(let move-queen ((columns safe-columns) (new-solutions solutions))
(if (null? columns) new-solutions
(move-queen
(cdr columns)
(if (attacks? 1 (car columns) solution) new-solutions
(next-queen (remq (car columns) safe-columns)
(cons (car columns) solution)
new-solutions)))))))
(unless (exact-positive-integer? N)
(raise-type-error 'N-Queens "exact-positive-integer" N))
(let ((rows (build-list N (λ (row) (add1 row)))))
(reverse (map (λ (columns) (map cons rows (reverse columns)))
(next-queen (build-list N (λ (i) (add1 i))) null null)))))
如果您考虑这个问题，列表确实是这个问题的自然数据结构。由于每一行只能放置一个皇后，因此需要做的就是将安全或未使用列的列表传递给下一行的迭代器。这是通过在 cond 子句中调用 remq 来完成的，该子句对 next-queen 进行回溯调用。
foldl 函数可以重写为命名的 let：
(define (next-queen safe-columns solution solutions)
(if (null? safe-columns)
(cons solution solutions)
(let move-queen ((columns safe-columns) (new-solutions solutions))
(if (null? columns) new-solutions
(move-queen
这要快得多，因为它避免了 foldl 内置的参数检查开销。在查看 PLT Scheme N-Queens 基准时，我遇到了使用隐式行的想法。从 1 的增量行开始并在检查解决方案时将其递增是非常巧妙的。出于某种原因，abs 在 PLT Scheme 中很昂贵，所以有更快的攻击形式吗？
在 PLT Scheme 中，您必须使用可变列表类型才能最快地实现。除了初始列列表之外，无需创建任何 cons 单元即可编写计算解决方案而不返回它们的基准。这避免了在 N = 17 之前收集垃圾，当时在 gc 中花费了 618 毫秒，而程序花费了 1 小时 51 分钟来寻找 95,815,104 个解决方案。
【讨论】：
【参考方案2】：又是我。这几天我一直在思考和苦恼这个问题，终于得到了答案。
因为没有人回答这个问题。我只是把它贴在这里给那些可能觉得有帮助的人。
对于那些好奇的人，我正在使用 DrScheme。
下面是代码。
#lang 方案 ; 行之间的代码是一个图形问题 ;它后来被改编成n皇后问题 ;------------------------------------------------ -------------------------------------------------- ---------------------- （定义（邻居节点图） （条件 （（空？图）'（）） ((symbol=? (first (first graph)) 节点) （第一（休息（第一张图）））） (else (neighbors node (rest graph))))) ;; find-route : node 节点图 -> (listof node) 或 false ;;在 G 中创建从起点到终点的路径 ;;如果没有路径，该函数将产生 false (define (find-route origin destination G) （条件 [(symbol=? origination destination) (list destination)] [else (local ((define possible-route （查找路由/列表（邻居起始 G）目的地 G））） （条件 [（布尔？可能路由）假] [else (cons origination possible-route)]))])) ;; find-route/list : (listof node) 节点图 -> (listof node) 或 false ;;创建从 lo-Os 上的某个节点到 D 的路径 ;;如果没有路径，该函数将产生 false （定义（查找路由/列出 lo-Os D G） （条件 [（空？lo-Os）假] [else (local ((define possible-route (find-route (first lo-Os) D G))) （条件 [(boolean? possible-route) (find-route/list (rest lo-Os) D G)] [其他可能的路线]））]）） （定义图 '((A (B E)) (乙(乙)) (C(D)) (D()) (E (C F)) (女(女)) （G （）））） ;测试 （查找路线'A'G图） ;------------------------------------------------ -------------------------------------------------- ---------------------- ;棋盘由#t/#f/'q 值的向量（又名数组）表示 ; #t 代表一个未被女王占据或威胁的位置 ; #f 表示受到皇后威胁的位置 ; 'q 代表一个被皇后占据的位置 ;可以通过 (build-vector (* n n) (lambda (x) #t)) 创建一个 n x n 的空棋盘 ;返回 a-board 的板长 ;例如。如果板是 8x8 板，则返回 8 （定义（板长a-board） （sqrt（向量长度的板））） ;返回板上索引的行 (define (get-row a-board index) (floor (/ index (board-length a-board)))) ;返回板上索引的列 (define (get-column a-board index) （剩余索引（板长 a-board））） ;如果索引 n1 引用的位置威胁到索引 n2 引用的位置，则返回 true，反之亦然 ;如果 n1 与 n2 在同一行/列/对角线上，则为 true （定义（受到威胁？a-board n1 n2） （条件 ((= (get-row a-board n1) (get-row a-board n2)) #t) ((= (get-column a-board n1) (get-column a-board n2)) #t) ((= (abs (- (get-row a-board n1) (get-row a-board n2))) (abs (- (get-column a-board n1) (get-column a-board n2)))) #t) （否则#f））） ; 在 a-board 的索引 n 上放置一个皇后后返回一个棋盘 （定义（place-queen-on-n a-board n） (本地 ((定义 (foo x)) （条件 ((= n x) 'q) ((eq? (vector-ref a-board x) 'q) 'q) ((eq? (vector-ref a-board x) #f) #f) （（受到威胁？a-board n x ）#f） （否则#t）））） (build-vector (vector-length a-board) foo))) ;返回在板上仍然可用的位置 ;基本上返回值为 #t 的位置 (define (get-possible-posn a-board) (local ((define (get-ava index)) （条件 ((= 索引 (向量长度 a-board)) '()) ((eq? (vector-ref a-board index) #t) （缺点索引（get-ava（add1 索引）））） (else (get-ava (add1 index)))))) (get-ava 0))) ;将皇后放在板上后返回板列表 ;此函数的作用类似于上述图形问题中的函数邻居 (define (place-a-queen a-board) (local ((define (place-queen lop)) （条件 （（空？lop）'（）） （否则（缺点（place-queen-on-n a-board (first lop)） (place-queen (rest lop))))))) (place-queen (get-possible-posn a-board)))) ;主功能 ;此函数的作用类似于上图问题中的函数 find-route （定义（place-n-queens 起始目的地 a-board） （条件 ((= 始发目的地) a-board) (else (local ((define possible-steps) (place-n-queens/list (add1 起源) 目的地 （放置一个女王板）））） （条件 （（布尔？可能的步骤）#f） （其他可能的步骤）））））） ;此函数的作用类似于上图中的函数 find-route/list （定义（place-n-queens/list originating destination board） （条件 （（空？板）#f） (else (local ((define possible-steps) （place-n-queens 起源 目的地 （第一板）））） （条件 （（布尔值？可能的步骤） （place-n-queens/list origination 目的地 （休息板））） （其他可能的步骤）））））） ;测试 ;在 8x8 棋盘上放置 8 个皇后 (place-n-queens 0 8 (build-vector (* 8 8) (lambda (x) #t)))【讨论】：
【参考方案3】：这是大约 11 年前我上函数式编程课时的情况，我认为这是使用 MIT 方案或 mzScheme。大多数情况下，它只是对我们使用的 Springer/Friedman 文本的修改，它刚刚解决了 8 个皇后。练习是将它推广到 N 个皇后，这段代码就是这样做的。
;_____________________________________________________
;This function tests to see if the next attempted move (try)
;is legal, given the list that has been constructed thus far
;(if any) - legal-pl (LEGAL PLacement list)
;N.B. - this function is an EXACT copy of the one from
;Springer and Friedman
(define legal?
(lambda (try legal-pl)
(letrec
((good?
(lambda (new-pl up down)
(cond
((null? new-pl) #t)
(else (let ((next-pos (car new-pl)))
(and
(not (= next-pos try))
(not (= next-pos up))
(not (= next-pos down))
(good? (cdr new-pl)
(add1 up)
(sub1 down)))))))))
(good? legal-pl (add1 try) (sub1 try)))))
;_____________________________________________________
;This function tests the length of the solution to
;see if we need to continue "cons"ing on more terms
;or not given to the specified board size.
;
;I modified this function so that it could test the
;validity of any solution for a given boardsize.
(define solution?
(lambda (legal-pl boardsize)
(= (length legal-pl) boardsize)))
;_____________________________________________________
;I had to modify this function so that it was passed
;the boardsize in its call, but other than that (and
;simply replacing "fresh-start" with boardsize), just
;about no changes were made. This function simply
;generates a solution.
(define build-solution
(lambda (legal-pl boardsize)
(cond
((solution? legal-pl boardsize) legal-pl)
(else (forward boardsize legal-pl boardsize)))))
;_____________________________________________________
;This function dictates how the next solution will be
;chosen, as it is only called when the last solution
;was proven to be legal, and we are ready to try a new
;placement.
;
;I had to modify this function to include the boardsize
;as well, since it invokes "build-solution".
(define forward
(lambda (try legal-pl boardsize)
(cond
((zero? try) (backtrack legal-pl boardsize))
((legal? try legal-pl) (build-solution (cons try legal-pl) boardsize))
(else (forward (sub1 try) legal-pl boardsize)))))
;_____________________________________________________
;This function is used when the last move is found to
;be unhelpful (although valid) - instead it tries another
;one until it finds a new solution.
;
;Again, I had to modify this function to include boardsize
;since it calls "forward", which has boardsize as a
;parameter due to the "build-solution" call within it
(define backtrack
(lambda (legal-pl boardsize)
(cond
((null? legal-pl) '())
(else (forward (sub1 (car legal-pl)) (cdr legal-pl) boardsize)))))
;_____________________________________________________
;This is pretty much the same function as the one in the book
;with just my minor "boardsize" tweaks, since build-solution
;is called.
(define build-all-solutions
(lambda (boardsize)
(letrec
((loop (lambda (sol)
(cond
((null? sol) '())
(else (cons sol (loop (backtrack sol boardsize))))))))
(loop (build-solution '() boardsize)))))
;_____________________________________________________
;This function I made up entirely myself, and I only
;made it really to satisfy the syntactical limitations
;of the laboratory instructions. This makes it so that
;the input of "(queens 4)" will return a list of the
;two possible configurations that are valid solutions,
;even though my modifiend functions would return the same
;value by simply inputting "(build-all-solutions 4)".
(define queens
(lambda (n)
(build-all-solutions n)))
【讨论】：
【参考方案4】：观看大师 (Hal Ableson) 的表演：
http://www.youtube.com/watch?v=skd-nyVyzBQ
【讨论】：
以上是关于Scheme中如何解决N-Queens？的主要内容，如果未能解决你的问题，请参考以下文章
如何使用 Select monad 解决 n-queens？