How to Solve N-Queens in Scheme?

Question

I'm stuck on the extended exercise 28.2 of How to Design Programs. I used a vector of true or false values to represent the board instead of using a list. This is what I've got which doesn't work:

#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)))))

Answer 1

This isn't the fastest scheme implementation possible, but it's pretty concise. I did come up with it independently, but I doubt it's unique. It's in PLT Scheme, so some function names need to be changed to get it running in R6RS. The list of solutions and each solution are built with cons, so they're reversed. The reverses and maps at the end reorder everything and add rows to the solutions for a pretty output. Most languages have a fold type function, see:
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)))))

If you think about the problem, a list is really the natural data structure for this problem. Since only one queen can be placed on each row, all that needs to be done is pass a list of safe or unused columns to the iterator for the next row. This is done with the call to remq in the cond clause that makes the backtracking call to next-queen.

The foldl function can be rewritten as a named 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

This is considerably faster, since it avoids the argument checking overhead built into foldl. I came across the idea of using implicit rows while looking at the PLT Scheme N-Queens benchmark. Starting with a delta-row of one and incrementing it as the solution is checked is pretty slick. For some reason, abs is expensive in PLT Scheme, so there is a faster form for attacks?

In PLT Scheme, you have to use the mutable list type for the fastest implementation. A benchmark that counts solutions without returning them can be written without creating any cons cells, other than the initial column list. This avoids collecting garbage until N = 17, when 618 milliseconds were spent in gc while the program spent 1 hour, 51 minutes finding the 95,815,104 solutions.

Answer 2

It's me again. I've been thinking and agonizing over the question for the past few days and finally got the answer.

Since no one has answered the question. I'll just post it here for those who might find it helpful.

For those who are curious, I'm using DrScheme.

Below is the code.

#lang scheme

;the code between the lines is a graph problem
;it is adapted into the n-queens problem later

;-------------------------------------------------------------------------------------------------------------------------

(define (neighbors node graph)
  (cond
    ((empty? graph) '())
    ((symbol=? (first (first graph)) node)
     (first (rest (first graph))))
    (else (neighbors node (rest graph)))))

;; find-route : node node graph  ->  (listof node) or false
;; to create a path from origination to destination in G
;; if there is no path, the function produces false
(define (find-route origination destination G)
  (cond
    [(symbol=? origination destination) (list destination)]
    [else (local ((define possible-route 
            (find-route/list (neighbors origination G) destination G)))
        (cond
          [(boolean? possible-route) false]
          [else (cons origination possible-route)]))]))

;; find-route/list : (listof node) node graph  ->  (listof node) or false
;; to create a path from some node on lo-Os to D
;; if there is no path, the function produces false
(define (find-route/list lo-Os D G)
  (cond
    [(empty? lo-Os) false]
    [else (local ((define possible-route (find-route (first lo-Os) D G)))
        (cond
          [(boolean? possible-route) (find-route/list (rest lo-Os) D G)]
          [else possible-route]))]))

  (define Graph 
    '((A (B E))
      (B (E F))
      (C (D))
      (D ())
      (E (C F))
      (F (D G))
      (G ())))

;test
(find-route 'A 'G Graph)

;-------------------------------------------------------------------------------------------------------------------------


; the chess board is represented by a vector (aka array) of #t/#f/'q values
; #t represents a position that is not occupied nor threatened by a queen
; #f represents a position that is threatened by a queen
; 'q represents a position that is occupied by a queen
; an empty chess board of n x n can be created by (build-vector (* n n) (lambda (x) #t))

; returns the board length of a-board
; eg. returns 8 if the board is an 8x8 board
(define (board-length a-board)
  (sqrt (vector-length a-board)))

; returns the row of the index on a-board
(define (get-row a-board index)
  (floor (/ index (board-length a-board))))

; returns the column of the index on a-board
(define (get-column a-board index)
  (remainder index (board-length a-board)))

; returns true if the position refered to by index n1 threatens the position refered to by index n2 and vice-versa
; true if n1 is on the same row/column/diagonal as n2
(define (threatened? a-board n1 n2)
  (cond
    ((= (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)
    (else #f)))

;returns a board after placing a queen on index n on a-board
(define (place-queen-on-n a-board n)
  (local ((define (foo x)
            (cond
              ((= n x) 'q)
              ((eq? (vector-ref a-board x) 'q) 'q)
              ((eq? (vector-ref a-board x) #f) #f)
              ((threatened? a-board n x ) #f)
              (else #t))))
    (build-vector (vector-length a-board) foo)))

; returns the possitions that are still available on a-board
; basically returns positions that has the value #t
(define (get-possible-posn a-board)
  (local ((define (get-ava index)
            (cond
              ((= index (vector-length a-board)) '())
              ((eq? (vector-ref a-board index) #t)
               (cons index (get-ava (add1 index))))
              (else (get-ava (add1 index))))))
    (get-ava 0)))

; returns a list of boards after placing a queen on a-board
; this function acts like the function neighbors in the above graph problem
(define (place-a-queen a-board)
  (local ((define (place-queen lop)
            (cond
              ((empty? lop) '())
              (else (cons (place-queen-on-n a-board (first lop))
                          (place-queen (rest lop)))))))
    (place-queen (get-possible-posn a-board))))

; main function
; this function acts like the function find-route in the above graph problem
(define (place-n-queens origination destination a-board)
  (cond
    ((= origination destination) a-board)
    (else (local ((define possible-steps
                    (place-n-queens/list (add1 origination)
                                         destination
                                         (place-a-queen a-board))))
            (cond
              ((boolean? possible-steps) #f)
              (else possible-steps))))))

; this function acts like the function find-route/list in the above graph problem
(define (place-n-queens/list origination destination boards)
  (cond
    ((empty? boards) #f)
    (else (local ((define possible-steps
                    (place-n-queens origination 
                                    destination 
                                    (first boards))))          
            (cond
              ((boolean? possible-steps)
               (place-n-queens/list origination 
                                    destination
                                    (rest boards)))
              (else possible-steps))))))

;test
;place 8 queens on an 8x8 board
(place-n-queens 0 8 (build-vector (* 8 8) (lambda (x) #t)))

Answer 3

Watch the master (Hal Ableson) do it:

http://www.youtube.com/watch?v=skd-nyVyzBQ

Answer 4

This is from about 11 years ago when I had a functional programming class, and I think this was using either MIT scheme or mzScheme. Mostly it's just modifications from the Springer/Friedman text that we used which just solved for 8 queens. The exercise was to generalize it for N queens, which this code does.

;_____________________________________________________
;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)))