sicp-ex-4.44

Short and clean

  
  
  
 (define (no-conflict col board) 
     (define (iter next k) 
         (or (null? next) 
             (and (not (= (car next) col)) 
                  (not (= (car next) (- col k)) 
                  (not (= (car next) (+ col k))))) 
                  (iter (cdr next) (+ k 1)))) 
     (iter board 1)) 
  
 (define (queens n) 
     (define (iter row result) 
         (if (= row n) 
             (display result) 
             (let ((col (an-integer-between 0 (- n 1)))) 
                 (require (no-conflict col result)) 
                 (iter (+ row 1) (cons col result))))) 
     (iter 0 '())) 

 ;; 
 ;; 
 ;; 
 ;; plain and straitforward solution 
 (define (queens) 
   (let ((q1 (amb 1 2 3 4 5 6 7 8))) 
     (let ((q2 (amb 1 2 3 4 5 6 7 8))) 
       (require (safe? q2 2 (rows->poses (list q1)))) 
       (let ((q3 (amb 1 2 3 4 5 6 7 8))) 
         (require (safe? q3 3 (rows->poses (list q1 q2)))) 
         (let ((q4 (amb 1 2 3 4 5 6 7 8))) 
           (require (safe? q4 4 (rows->poses (list q1 q2 q3)))) 
           (let ((q5 (amb 1 2 3 4 5 6 7 8))) 
             (require (safe? q5 5 (rows->poses (list q1 q2 q3 q4)))) 
             (let ((q6 (amb 1 2 3 4 5 6 7 8))) 
               (require (safe? q6 6 (rows->poses (list q1 q2 q3 q4 q5)))) 
               (let ((q7 (amb 1 2 3 4 5 6 7 8))) 
                 (require (safe? q7 7 (rows->poses (list q1 q2 q3 q4 q5 q6)))) 
                 (let ((q8 (amb 1 2 3 4 5 6 7 8))) 
                   (require (safe? q8 8 (rows->poses (list q1 q2 q3 q4 q5 q6 q7)))) 
                   (rows->poses (list q1 q2 q3 q4 q5 q6 q7 q8))))))))))) 
  
 ;; helper functions 
 (define (and a b c d) 
   (cond ((not a) false) 
         ((not b) false) 
         ((not c) false) 
         ((not d) false) 
         (else true)))       
  
 (define (or a b) 
   (if a 
       true 
       b)) 
  
 ;; 2.42 
 (define (same-row? p1 p2) 
   (= (car p1) (car p2))) 
  
 (define (same-col? p1 p2) 
   (= (cdr p1) (cdr p2))) 
  
 (define (same-diag? p1 p2) 
   (let ((row1 (car p1)) 
         (col1 (cdr p1)) 
         (row2 (car p2)) 
         (col2 (cdr p2))) 
     (or (= (+ row1 col1) (+ row2 col2)) 
         (= (- row1 col1) (- row2 col2))))) 
  
 (define (safe? row col positions) 
   (define (safe-iter kp other-positions) 
     (if (null? other-positions) 
         true 
         (and (not (same-row? kp (car other-positions))) 
              (not (same-col? kp (car other-positions))) 
              (not (same-diag? kp (car other-positions))) 
              (safe-iter kp (cdr other-positions))))) 
   (safe-iter (cons row col) positions)) 
  
 (define (map proc items) 
   (if (null? items) 
       '() 
       (cons (proc (car items)) 
             (map proc (cdr items))))) 
  
 (define (rows->poses rows) 
   (define count 0) 
   (map (lambda (row) 
          (begin (set! count (+ count 1)) 
                 (cons row count))) 
        rows)) 
  
 (queens) 
  

 ;; 
 ;; 
 ;; 
 (define (vulnerable? queen1-position queen2-position column-separation) 
   (let ((row-separation (abs (- queen1-position queen2-position)))) 
     (or (= row-separation 0) 
         (= row-separation column-separation)))) 
  
 ;; first element of previous-queens is the position of the queen 
 ;; in the column immediately adjacent to next-queen 
 (define (next-queen-vulnerable? next-queen previous-queens) 
   (define (iter prev-qs column-separation) 
     (if (null? prev-qs) 
         false 
         (or (vulnerable? next-queen (car prev-qs) column-separation) 
             (iter (cdr prev-qs) (1+ column-separation))))) 
   (iter previous-queens 1)) 
  
 ;; use let* even though bindings are independent in order to guarantee efficient nesting with respect to amb. 
 (define (eight-queens) 
   (define (nnqv? next-queen previous-queens) 
     (not (next-queen-vulnerable? next-queen previous-queens))) 
   (let* ((prev0 '()) 
          (q1 (amb 1 2 3 4 5 6 7 8))) 
     (require (nnqv? q1 prev0)) ;; trivially never fails 
     (let* ((prev1 (cons q1 prev0)) 
            (q2 (amb 1 2 3 4 5 6 7 8))) 
       (require (nnqv? q2 prev1)) 
       (let* ((prev2 (cons q2 prev1)) 
              (q3 (amb 1 2 3 4 5 6 7 8))) 
         (require (nnqv? q3 prev2)) 
         (let* ((prev3 (cons q3 prev2)) 
                (q4 (amb 1 2 3 4 5 6 7 8))) 
           (require (nnqv? q4 prev3)) 
           (let* ((prev4 (cons q4 prev3)) 
                  (q5 (amb 1 2 3 4 5 6 7 8))) 
             (require (nnqv? q5 prev4)) 
             (let* ((prev5 (cons q5 prev4)) 
                    (q6 (amb 1 2 3 4 5 6 7 8))) 
                (require (nnqv? q6 prev5)) 
                (let* ((prev6 (cons q6 prev5)) 
                       (q7 (amb 1 2 3 4 5 6 7 8))) 
                  (require (nnqv? q7 prev6)) 
                  (let* ((prev7 (cons q7 prev6)) 
                         (q8 (amb 1 2 3 4 5 6 7 8))) 
                    (require (nnqv? q8 prev7)) 
                    (cons q8 prev7)))))))))) 
 ;; use try-again to go through all the solutions. 

  
  
  
 ;; 4.44 
 (define (enumerate-interval low high) 
   (if (> low high) 
       '() 
       (cons low (enumerate-interval (+ low 1) high)))) 
  
 (define (attack? row1 col1 row2 col2) 
   (or (= row1 row2) 
       (= col1 col2) 
       (= (abs (- row1 row2)) (abs (- col1 col2))))) 
  
 ;; positions is the list of row of former k-1 queens 
 (define (safe? k positions) 
   (let ((kth-row (list-ref positions (- k 1)))) 
     (define (safe-iter p col) 
       (if (>= col k) 
           true 
           (if (attack? kth-row k (car p) col) 
               false 
               (safe-iter (cdr p) (+ col 1))))) 
     (safe-iter positions 1))) 
  
 (define (list-amb li) 
   (if (null? li) 
       (amb) 
       (amb (car li) (list-amb (cdr li))))) 
  
 (define (queens board-size) 
   (define (queen-iter k positions) 
     (if (= k board-size) 
         positions 
         (let ((row (list-amb (enumerate-interval 1 board-size)))) 
           (let((new-pos (append positions (list row)))) 
             (require (safe? k new-pos)) 
             (queen-iter (+ k 1) new-pos))))) 
   (queen-iter 1 '())) 

  
 ;; a simpler version. 
  
 (define (an-integer-between a b) 
     (require (<= a b)) 
     (amb a (an-integer-between (+ a 1) b))) 
  
 ;;check if (car solution) is compatible with any of (cdr solution) 
 (define (safe? solution)  
     (let ((p (car solution))) 
         (define (conflict? q i) 
             (or 
                 (= p q) 
                 (= p (+ q i)) 
                 (= p (- q i)))) 
         (define (check rest i) 
             (cond  
                 ((null? rest) #t) 
                 ((conflict? (car rest) i) #f) 
                 (else (check (cdr rest) (inc i))))) 
         (check (cdr solution) 1))) 
  
 (define (queens n) 
     (define (iter solution n-left) 
         (if (= n-left 0) 
             (begin 
                 (display solution) 
                 (newline)) 
             (begin 
                 (let ((x-solution (cons (an-integer-between 1 n) solution))) 
                     (require (safe? x-solution)) 
                     (iter x-solution (- n-left 1)))))) 
     (iter '() n)) 
  
 (queens 8) 
  

 ;;use the original method 
  
 (define (enumerate-interval l h) 
   (if (> l h) 
       '() 
       (cons l (enumerate-interval (+ l 1) h)))) 
 (define empty-board '()) 
 (define (adjoin-position row col rest) 
   (cons (list row col) rest)) 
 (define (extract item lst) 
   (define (scan items) 
     (cond ((null? items) 
            '()) 
           ((equal? item (car items)) 
            (scan (cdr items))) 
           (else (cons (car items) (scan (cdr items)))))) 
   (scan lst)) 
 (define (safe? col positions) 
   (define (iter l) 
     (if (null? l) 
         true 
         (and (car l) (iter (cdr l))))) 
   (let ((row (caar (filter (lambda (p) 
                              (eq? col (cadr p))) 
                            positions)))) 
     (iter (map (lambda (p) 
                  (not (or (eq? row (car p)) 
                           (eq? (- row col) (- (car p) (cadr p))) 
                           (eq? (+ row col) (+ (car p) (cadr p)))))) 
                (extract (list row col) positions))))) 
 (define (queens board-size) 
   (define (queen-cols k) 
     (if (= k 0) 
         (list empty-board) 
         (map (lambda (positions) 
                (require (safe? k positions))) 
              (flatmap (lambda (rest-of-queens) 
                         (adjoin-position new-row (amb (enumerate-interval 1 board-size)) 
                                          rest-of-queens)) 
                       (queen-cols (- k 1)))))) 
   (queen-cols board-size)) 

(define (new-queen col)
  (cons col (amb 1 2 3 4 5 6 7 8)))

(define (8queens)
  (define (iter queens)
    (require (distinct? (map cdr queens)))
    (require (distinct? (map (lambda (q) (- (car q) (cdr q))) queens)))
    (require (distinct? (map (lambda (q) (+ (car q) (cdr q))) queens)))
    (if (= 8 (length queens))
        queens
        (iter (cons (new-queen (+ 1 (length queens))) queens))))
  (iter '()))

;; ((8 . 4) (7 . 2) (6 . 7) (5 . 3) (4 . 6) (3 . 8) (2 . 5) (1 . 1))

I keep track of all the history of my solutions.

 ;; Exercise 4.44 
 (define (Eight-Queen) 
     (define (add-constraint Rx Ry diff) 
     (require (not (= Rx Ry))) 
     (require (not (= (abs (- Ry Rx)) diff)))) 
    
   (let ([r1 (amb 1 2 3 4 5 6 7 8)]) 
     (let ([r2 (amb 1 2 3 4 5 6 7 8)]) 
       (add-constraint r1 r2 1) 
       (let ([r3 (amb 1 2 3 4 5 6 7 8)]) 
         (add-constraint r1 r3 2) 
         (add-constraint r2 r3 1) 
         (let ([r4 (amb 1 2 3 4 5 6 7 8)]) 
           (add-constraint r1 r4 3) 
           (add-constraint r2 r4 2) 
           (add-constraint r3 r4 1) 
           (let ([r5 (amb 1 2 3 4 5 6 7 8)]) 
             (add-constraint r1 r5 4) 
             (add-constraint r2 r5 3) 
             (add-constraint r3 r5 2) 
             (add-constraint r4 r5 1) 
             (let ([r6 (amb 1 2 3 4 5 6 7 8)]) 
               (add-constraint r1 r6 5) 
               (add-constraint r2 r6 4) 
               (add-constraint r3 r6 3) 
               (add-constraint r4 r6 2) 
               (add-constraint r5 r6 1) 
               (let ([r7 (amb 1 2 3 4 5 6 7 8)]) 
                 (add-constraint r1 r7 6) 
                 (add-constraint r2 r7 5) 
                 (add-constraint r3 r7 4) 
                 (add-constraint r4 r7 3) 
                 (add-constraint r5 r7 2) 
                 (add-constraint r6 r7 1) 
                 (let ([r8 (amb 1 2 3 4 5 6 7 8)]) 
                   (add-constraint r1 r8 7) 
                   (add-constraint r2 r8 6) 
                   (add-constraint r3 r8 5) 
                   (add-constraint r4 r8 4) 
                   (add-constraint r5 r8 3) 
                   (add-constraint r6 r8 2) 
                   (add-constraint r7 r8 1) 
                   (list r1 r2 r3 r4 r5 r6 r7 r8)))))))))) 
  
 ;; Additional Exercise 4.44 
 (define (Eight-Queen) 
   (define (add-constraint Rx Ry diff) 
     (require (not (= Rx Ry))) 
     (require (not (= (abs (- Ry Rx)) diff)))) 
  
   ;; add constraints to all two elements, both of them are from ``rows`` 
   (define (add-constraints rows) 
      
     ;; add constraints to all two elements where one is the CAR of ``rows`` and the other 
     ;; is from the CDR ``rows`` 
     (define (loop items diff) 
       (if (not (null? items)) 
           (begin 
             (add-constraint (car rows) (car items) diff) 
             (loop (cdr items) (+ diff 1))))) 
      
     (if (not (null? (cdr rows))) 
         (begin 
           (loop (cdr rows) 1) 
           (add-constraints (cdr rows))))) 
    
   (let ([r1 (amb 1 2 3 4 5 6 7 8)] 
         [r2 (amb 1 2 3 4 5 6 7 8)] 
         [r3 (amb 1 2 3 4 5 6 7 8)] 
         [r4 (amb 1 2 3 4 5 6 7 8)] 
         [r5 (amb 1 2 3 4 5 6 7 8)] 
         [r6 (amb 1 2 3 4 5 6 7 8)] 
         [r7 (amb 1 2 3 4 5 6 7 8)] 
         [r8 (amb 1 2 3 4 5 6 7 8)]) 
     (add-constraints (list r1 r2 r3 r4 r5 r6 r7 r8)) 
     (list r1 r2 r3 r4 r5 r6 r7 r8))) 
  
  
 (define (Eight-Queen) 
   ;; add a constraint to two elements with a specifed difference 
   (define (add-constraint Rx Ry diff) 
     (require (not (= Rx Ry)))                 ; not in a same column 
     (require (not (= (abs (- Ry Rx)) diff)))) ; not in a same diagonal 
  
   ;; add constraints to all two elements where one is the CAR of ``rows`` and the other 
   ;; is from the CDR ``rows`` 
   ;; the procedure take a list which is ordered by "descended" (from high row to low row) 
   (define (add-constraints rows) 
     (define (loop rest diff) 
       (if (not (null? rest)) 
           (begin 
             (add-constraint (car rows) (car rest) diff) 
             (loop (cdr rest) (+ diff 1))))) 
     (loop (cdr rows) 1)) 
    
   (let ([r1 (amb 1 2 3 4 5 6 7 8)]) 
     (let ([r2 (amb 1 2 3 4 5 6 7 8)]) 
       (add-constraints (list r2 r1)) 
       (let ([r3 (amb 1 2 3 4 5 6 7 8)]) 
         (add-constraints (list r3 r2 r1)) 
         (let ([r4 (amb 1 2 3 4 5 6 7 8)]) 
           (add-constraints (list r4 r3 r2 r1)) 
           (let ([r5 (amb 1 2 3 4 5 6 7 8)]) 
             (add-constraints (list r5 r4 r3 r2 r1))   
             (let ([r6 (amb 1 2 3 4 5 6 7 8)]) 
               (add-constraints (list r6 r5 r4 r3 r2 r1)) 
               (let ([r7 (amb 1 2 3 4 5 6 7 8)]) 
                 (add-constraints (list r7 r6 r5 r4 r3 r2 r1)) 
                 (let ([r8 (amb 1 2 3 4 5 6 7 8)]) 
                   (add-constraints (list r8 r7 r6 r5 r4 r3 r2 r1)) 
                   (list r1 r2 r3 r4 r5 r6 r7 r8)))))))))) 
  
 (define (Eight-Queen) 
   ;; add a constraint to two elements with a specifed difference 
   (define (add-constraint Rx Ry diff) 
     (require (not (= Rx Ry)))                 ; not in a same column 
     (require (not (= (abs (- Ry Rx)) diff)))) ; not in a same diagonal 
  
   ;; add constraints to all two elements where one is the CAR of ``rows`` and the other 
   ;; is from the CDR ``rows`` 
   ;; the procedure take a list which is ordered by "descended" (from high row to low row) 
   (define (add-constraints rows) 
     (define (loop rest diff) 
       (if (not (null? rest)) 
           (begin 
             (add-constraint (car rows) (car rest) diff) 
             (loop (cdr rest) (+ diff 1))))) 
     (loop (cdr rows) 1)) 
    
   (define (get-solution r-rows stage) 
     (if (< stage 9) 
         (let ([row (amb 1 2 3 4 5 6 7 8)]) 
           (let ([new-rows (cons row r-rows)]) 
             (add-constraints new-rows) 
             (get-solution new-rows (+ stage 1)))) 
         (reverse r-rows))) 
    
   (get-solution (list (amb 1 2 3 4 5 6 7 8)) 2)) 
  
 (define (N-Queen n) 
   ;; add a constraint to two elements with a specifed difference 
   (define (add-constraint Rx Ry diff) 
     (require (not (= Rx Ry)))                 ; not in a same column 
     (require (not (= (abs (- Ry Rx)) diff)))) ; not in a same diagonal 
  
   ;; add constraints to all two elements where one is the CAR of ``rows`` and the other 
   ;; is from the CDR ``rows`` 
   ;; the procedure take a list which is ordered by "descended" (from high row to low row) 
   (define (add-constraints rows) 
     (define (loop rest diff) 
       (if (not (null? rest)) 
           (begin 
             (add-constraint (car rows) (car rest) diff) 
             (loop (cdr rest) (+ diff 1))))) 
     (loop (cdr rows) 1)) 
    
   (define (get-solution r-rows stage) 
     (if (< stage n) 
         (let ([row (an-integer-between 1 n)]) 
           (let ([new-rows (cons row r-rows)]) 
             (add-constraints new-rows) 
             (get-solution new-rows (+ stage 1)))) 
         (reverse r-rows))) 
    
   (get-solution (list (an-integer-between 1 n)) 1)) 
  
 ;;; represent Queens as a list of columns in the order of the rows 
 (define (N-Queen n) 
   ;; check if two queens coexist with each other   
   (define (offensive? Rx Ry diff) 
     (if (= Rx Ry)                       ; in a same column 
         true 
         (= (abs (- Ry Rx)) diff)))      ; in a same diagonal 
    
   ;; check if (car solution) is compatible with any of (cdr solution)  
   (define (safe? rows) 
     (define (check rest diff) 
       (if (not (null? rest)) 
           (if (offensive? (car rows) (car rest) diff) 
               false 
               (check (cdr rest) (+ diff 1))) 
           true)) 
     (check (cdr rows) 1)) 
    
   (define (queen-iter r-rows stage) 
     (if (< stage n) 
         (let ([row (an-integer-between 1 n)]) 
           (let ([new-rows (cons row r-rows)]) 
             (require (safe? new-rows)) 
             (queen-iter new-rows (+ stage 1)))) 
         (reverse r-rows))) 
    
   (queen-iter (list (an-integer-between 1 n)) 1)) 

Full brute force using "distinct" was too slow to even attempt. At first I optimized by generating permutations as follows:

  
 (define (a-permutation-of s) 
   (define (amb-permutations s) 
     (define (proc x) 
       (map (lambda (p) (cons x p)) (amb-permutations (delete x s)))) 
      
     (define (iter sequence) 
       (if (null? sequence) 
           (amb) 
           (amb (proc (car sequence)) 
                (iter (cdr sequence))))) 
  
     (if (null? s) 
         (list '()) 
         (iter s))) 
    
   (car (amb-permutations s))) 
  

Then ruling out those permutations with diagonal conflicts. That was still pretty slow so I went for a dynamic programming solution:

  
 (define (n-queens-dp n k) 
  
   (define (choices rest-of-board) 
     (define (conflicts-diagonal? x op board) 
       (cond ((null? board) false) 
             ((= (car board) x) true) 
             (else (conflicts-diagonal? (op x) op (cdr board))))) 
  
     (define (good-choice choice) 
       (cond ((memq choice rest-of-board) false) 
             ((conflicts-diagonal? (- choice 1) 
                                   (lambda (x) (- x 1)) rest-of-board) false) 
             ((conflicts-diagonal? (+ choice 1) 
                                   (lambda (x) (+ x 1)) rest-of-board) false) 
             (else true))) 
      
     (filter good-choice (upto k))) 
    
   (if (= n 0) 
       '()   
       (let ((rest-of-board (n-queens-dp (- n 1) k))) 
         (cons (an-element-of (choices rest-of-board)) 
               rest-of-board))))