Scheme, N-queens optimization strategies SICP chapter 2

Question

SICP contains an partially complete example of the n-queens solutions, by walking a tree of every possible queen placement in the last row, generating more possible positions in the next row to combine the results so far, filtering the possibilities to keep only ones where the newest queen is safe, and repeating recursively.

This strategy blows up after about n=11 with a maximum recursion error.

I've implemented an alternate strategy that does a smarter tree-walk from the first column, generating possible positions from a list of unused rows, consing each position-list onto an updated list of yet-unused rows. Filtering those pairs considered safe, and recursively mapping over these pairs for the next column. This doesn't blow up (so far) but n=12 takes a minute and n=13 takes about 10 minutes to solve.

(define (queens board-size)
 (let loop ((k 1) (pp-pair (cons '() (enumerate-interval 1 board-size))))
   (let ((position (car pp-pair))
         (potential-rows (cdr pp-pair)))
    (if (> k board-size) 
        (list position)
        (flatmap (lambda (pp-pair) (loop (++ k) pp-pair)) 
         (filter (lambda (pp-pair) (safe? k (car pp-pair))) ;keep only safe
          (map (lambda (new-row) 
                (cons (adjoin-position new-row k position) 
                      (remove-row new-row potential-rows))) ;make pp-pair
           potential-rows))))))) 
;auxiliary functions not listed 

Not really looking for code, but a simple explanation of a strategy or two that's less naive and that clicks well with a functional approach.

Answer 1

I can offer you a simplification of your code, so it may run a little bit faster. We start by renaming some variables for improved readability (YMMV),

(define (queens board-size)
 (let loop ((k 1) 
            (pd (cons '() (enumerate-interval 1 board-size))))
   (let ((position (car pd))
         (domain   (cdr pd)))
    (if (> k board-size) 
        (list position)
        (flatmap (lambda (pd) (loop (1+ k) pd)) 
         (filter (lambda (pd) (safe? k (car pd))) ;keep only safe NewPositions
          (map (lambda (row) 
                (cons (adjoin-position row k position)  ;NewPosition
                      (remove-row row domain))) ;make new PD for each Row in D
               domain)))))))                            ; D

Now, filter f (map g d) == flatmap (\x->let {y=g x} in [y | f y]) d (using a bit of Haskell syntax there), i.e. we can fuse the map and the filter into one flatmap:

        (flatmap (lambda (pd) (loop (1+ k) pd)) 
         (flatmap (lambda (row)                   ;keep only safe NewPositions
               (let ( (p (adjoin-position row k position))
                      (d (remove-row row domain)))
                 (if (safe? k p) 
                     (list (cons p d)) 
                     '())))
            domain)) 

then, flatmap h (flatmap g d) == flatmap (h <=< g) d (where <=< is right-to-left Kleisli composition operator, but who cares), so we can fuse the two flatmaps into just one, with

        (flatmap 
            (lambda (row)                         ;keep only safe NewPositions
                (let ((p (adjoin-position row k position)))
                  (if (safe? k p)
                    (loop (1+ k) (cons p (remove-row row domain)))
                    '())))
            domain)

so the simplified code is

(define (queens board-size)
 (let loop ((k        1) 
            (position '())
            (domain   (enumerate-interval 1 board-size)))
    (if (> k board-size) 
        (list position)
        (flatmap 
            (lambda (row)                         ;use only the safe picks
              (if (safe_row? row k position)      ;better to test before consing
                (loop (1+ k) (adjoin-position row k position)
                             (remove-row row domain))
                '()))
            domain))))

Answer 2

Here's what I came up with a second time around. Not sure it's terribly much faster though. Quite a bit prettier though.

(define (n-queens n)
  (let loop ((k 1) (r 1) (dangers (starting-dangers n)) (res '()) (solutions '()))
    (cond ((> k n) (cons res solutions))
          ((> r n) solutions)
          ((safe? r k dangers) 
           (let ((this (loop (+ k 1) 1 (update-dangers r k dangers) 
                             (cons (cons r k) res) solutions)))
             (loop k (+ r 1) dangers res this)))
          (else (loop k (+ r 1) dangers res solutions)))))

Big thing is using a let statement to serialize recursion, limiting depth to n. Solutions come out backwards (could probably fix by going n->1 instead of 1->n on r and k) but a backwards set is the same set as the frowards set.

(define (starting-dangers n)
  (list (list)
        (list (- n))
        (list (+ (* 2 n) 1))))
;;instead of terminating in null list, terminate in term that cant threaten

small improvement, a danger can come from a row, a down diagonal, or and up diagonal, keep track of each as the board evolves.

(define (safe? r k dangers)
   (and (let loop ((rdangers (rdang dangers)))
           (cond ((null? rdangers) #t)
                 ((= r (car rdangers))
                  #f)
                 (else (loop (cdr rdangers)))))
        (let ((ddiag (- k r)))
           (let loop ((ddangers (ddang dangers)))
              (if (<= (car ddangers) ddiag)
                  (if (= (car ddangers) ddiag)
                      #f
                      #t)
                  (loop (cdr ddangers)))))
        (let ((udiag (+ k r)))
           (let loop ((udangers (udang dangers)))
              (if (>= (car udangers) udiag)
                  (if (= (car udangers) udiag)
                      #f
                      #t)
                  (loop (cdr udangers)))))))

medium improvement in the change of format, only needing to do one comparison to check vs prior two. Don't think keeiping diagonals sorted cost me anything, but I don't think it saves time either.

(define (update-dangers r k dangers)
  (list
     (cons r (rdang dangers))
     (insert (- k r) (ddang dangers) >)
     (insert (+ k r) (udang dangers) <))) 

 (define (insert x sL pred)
   (let loop ((L sL))
      (cond ((null? L) (list x))
            ((pred x (car L))
             (cons x L))
            (else (cons (car L)
                        (loop (cdr L)))))))

(define (rdang dangers)
  (car dangers))
(define (ddang dangers)
  (cadr dangers))
(define (udang dangers)
  (caddr dangers))