sicp-ex-2.42


 ;;; The empty board 
 (define empty-board nil) 
  
 ;;; Constructor and selectors for queen placements. 
 (define (place-queen rank file) 
   (cons rank file)) 
  
 (define (queen-rank queen) 
   (car queen)) 
  
 (define (queen-file queen) 
   (cdr queen)) 
  
 ;;; ADJOIN-POSITION places a new queen in a board position. 
 (define (adjoin-position rank file board) 
   (cons (place-queen rank file) 
         board)) 
  
 ;;; FIND-FIRST returns the leftmost element of a list for which PRED is 
 ;;; true, or NIL if there are no matches. 
 (define (find-first pred items) 
   (cond ((null? items) nil) 
         ((pred (car items)) 
          (car items)) 
         (else (find-first pred (cdr items))))) 
  
 ;;; SAFE? tests if the queen in a file is safe from attack. 
 (define (safe? file board) 
   (define (get-queen-by-file file board) 
     (find-first (lambda (queen) 
                   (= (queen-file queen) file)) 
                 board)) 
  
   (let* ((the-queen 
           (get-queen-by-file file board)) 
          (other-queens 
           (filter (lambda (q) 
                     (not (and (= (queen-rank the-queen) 
                                  (queen-rank q)) 
                               (= (queen-file the-queen) 
                                  (queen-file q))))) 
                   board))) 
      
     ;; To be safe, THE-QUEEN must not share with any other queen either the 
     ;; same rank… 
     (and (not (accumulate (lambda (p q) 
                             (or q 
                                 (= (queen-rank p) 
                                    (queen-rank the-queen)))) 
                           #f 
                           other-queens)) 
  
          ;; …or the same diagonal, which is the case if 
          ;;      (= (ABS (- (QUEEN-RANK THE-QUEEN) (QUEEN-RANK ANY-QUEEN))) 
          ;;         (ABS (- (QUEEN-FILE THE-QUEEN) (QUEEN-FILE ANY-QUEEN)))) 
          (not (accumulate (lambda (p q) 
                             (or q 
                                 (= (abs (- (queen-rank the-queen) (queen-rank p))) 
                                    (abs (- (queen-file the-queen) (queen-file p)))))) 
                           #f 
                           other-queens))))) 
  
 ;;; The main QUEENS procedure to solve the n-Queens Problem. 
 (define (queens board-size) 
   (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)) 

<< Previous exercise (2.41) | Index | Next exercise (2.44) >>

yh

This is one rather simple solution similar to the ones at the bottom

  
 (define (queens board-size) 
   (define (queen-cols k) 
     (if (= k 0) 
         (list empty-board) 
          
         (filter 
          ; This checks if the current queen is safe from the rest of the queens 
          (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)) 
  
  
 ; Adds a new row to the board (list) 
 (define (adjoin-position new-row k rest-of-queens) 
   (cons new-row rest-of-queens)) 
  
  
  
 (define empty-board '()) 
  
  
  
 ; current queen is at start of positions, check it against rest of the queens 
 (define (safe? k positions) 
   ; current queen is at start of positions list 
   (define queenPos (car positions)) 
    
   ; top and bot are used to check for diagonal entries 
   (define (safe-iter top bot remain) 
     (cond ((null? remain) 
            #t) 
            
           ; Checks for same row and diagonals 
           ((or (= (car remain) queenPos) 
                (= (car remain) top) 
                (= (car remain) bot)) 
            #f) 
            
           (else 
            (safe-iter (- top 1) (+ bot 1) (cdr remain))))) 
    
   (safe-iter (- queenPos 1) (+ queenPos 1) (cdr positions))) 
  
  
  
  
 ; Helper procedures 
 (define (flatmap proc seq) 
   (accumulate append '() (map proc seq))) 
  
  
 (define (accumulate op init seq) 
   (if (null? seq) 
       init 
       (op (car seq) 
           (accumulate op init (cdr seq))))) 
  
  
 (define (enumerate-interval low high) 
   (if (> low high) 
       '() 
       (cons low (enumerate-interval (+ low 1) high)))) 
  
  


jz

I found the function to be a bit hard to read. Example: why adjoin-position, when you're really adding a queen (hence add-queen). So I renamed many parts, as shown below. Some simple tests are included to demonstrate that the constituent parts are working as expected.

  
 ;; Queens puzzle. 
  
 ;; --------------------------- 
 ;; Support. 
  
 (define nil '()) 
  
 ;; Builds a list of sequence items that pass the predicate. 
 (define (filter predicate sequence) 
   (cond ((null? sequence) nil) 
         ((predicate (car sequence)) 
          (cons (car sequence)  
                (filter predicate (cdr sequence)))) 
         (else (filter predicate (cdr sequence))))) 
  
 ;; Accumulates the result of the first and the already-accumulated 
 ;; rest. 
 (define (accumulate op initial sequence) 
   (if (null? sequence) 
       initial 
       (op (car sequence) 
           (accumulate op initial (cdr 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 (select-item n items) 
   (cond ((null? items) (error "out of items?" n)) 
         ((= 1 n) (car items)) 
         (else (select-item (- n 1) (cdr items))))) 
  
  
 ;; --------------------------- 
  
 ;; The data abstraction.  A queen's position can be given as (cons row 
 ;; column).  A position is just a list of queens. 
  
 ;; Accessors: 
 (define (make-empty-board) '()) 
  
 ;; Queen position: 
 (define (make-queen row column) (cons row column)) 
 (define (queen-row q) (car q)) 
 (define (queen-column q) (cdr q)) 
  
 ;; Really should check for queen in same row, column. 
 (define (add-queen row column queens-already-placed) 
   (cons (make-queen row column) queens-already-placed)) 
  
  
 ;; Returns nil if no queen in that column. 
 (define (get-queen-in-column column queens) 
   (define (first-queen qs) (car qs)) 
   (cond ((null? queens) nil) 
         ((= (queen-column (first-queen queens)) column) 
          (first-queen queens)) 
         (else (get-queen-in-column column (cdr queens))))) 
  
  
 ;; --------------------------- 
 ;; Queen safety. 
  
 ;; A queen will be safe if it is in a) its own column, b) its own row, 
 ;; and c) its own diagonals.  a) and b) are easy; as for c), we just 
 ;; need to check that the slope of the line formed by the two queens 
 ;; is 1 or -1, or that the absolute value of the row difference is the 
 ;; same as that of the column difference. 
 (define (on-same-column q1 q2) (= (queen-column q1) (queen-column q2))) 
 (define (on-same-row q1 q2) (= (queen-row q1) (queen-row q2))) 
 (define (on-same-diag q1 q2) 
   (= (abs (- (queen-row q1) (queen-row q2))) 
      (abs (- (queen-column q1) (queen-column q2))))) 
  
 (define (safe-from-attack q1 q2) 
   (or (and (on-same-row q1 q2) 
            (on-same-column q1 q2))  ;; q can't attack itself! 
  
       (and (not (on-same-column q1 q2)) 
            (not (on-same-row q1 q2)) 
            (not (on-same-diag q1 q2))))) 
  
  
 ;; Returns true if the queen in the given column is safe from attack 
 ;; by all other queens (ie no other queens are on the same row or 
 ;; diagonal). 
 (define (safe? column all-queens) 
   (let ((q-in-col (get-queen-in-column column all-queens))) 
     ;; For some reason, couldn't just pass "and" as the operator, 
     ;; would get error: ";Syntactic keyword may not be used as an 
     ;; expression: #f". 
     (accumulate (lambda (a b) (and a b)) 
                 true 
                 (map (lambda (q) (safe-from-attack q-in-col q)) 
                      all-queens)))) 
  
  
 ;; ------------------------- 
 ;; <TESTING> 
  
 (define (ensure expected-true message) 
   (if (not expected-true) 
       (error "Failure: " message))) 
  
  
 ;; Defining the current position for columns 1 to 3: 
 ;; --3. 
 ;; 1--. 
 ;; -2-. 
  
 (define base-pos (add-queen 3 3  
                             (add-queen 1 2  
                                        (add-queen 2 1  
                                                   (make-empty-board))))) 
  
 (get-queen-in-column 2 base-pos) 
 (get-queen-in-column 1 base-pos) 
 (get-queen-in-column 4 base-pos) 
  
 ;; Tests 
 (define q1-1 (make-queen 1 1)) 
 (define q1-3 (make-queen 1 3)) 
 (define q3-3 (make-queen 3 3)) 
 (define q2-2 (make-queen 2 2)) 
 (define q4-6 (make-queen 4 6)) 
 (define q5-5 (make-queen 5 5)) 
  
 (ensure (on-same-column q1-3 q3-3) "both in 3rd col") 
 (ensure (not (on-same-column q2-2 q3-3)) "diff cols") 
 (ensure (on-same-row q1-3 q1-1) "1st row") 
 (ensure (not (on-same-row q1-1 q3-3)) "diff row") 
 (ensure (on-same-diag q1-1 q3-3) "asc diag") 
 (ensure (on-same-diag q1-3 q4-6) "asc diag 1-3") 
 (ensure (on-same-diag q5-5 q4-6) "desc diag 5-5") 
 (ensure (not (on-same-diag q4-6 q1-1)) "diff diag") 
 (ensure (safe-from-attack q1-1 q4-6) "safe") 
 (ensure (not (safe-from-attack q1-1 q5-5)) "same diag") 
 (ensure (not (safe-from-attack q4-6 q5-5)) "desc diag") 
 (ensure (safe-from-attack q1-1 q1-1) "queen can't attack itself") 
  
 (ensure (safe? 3 base-pos) "on own row, col, and diag") 
 (ensure (not (safe? 2 base-pos)) "on desc diag with 1") 
 (ensure (not (safe? 1 base-pos)) "on desc diag with 2") 
  
 ;; </TESTING> 
 ;; ------------------------- 
  
  
 ;; The function. 
  
 (define (queens board-size) 
   (define row-numbers (enumerate-interval 1 board-size)) 
   (define empty-board (make-empty-board)) 
  
   (define (safely-place-queen-in-column column) 
     (if (= column 0) 
         (list empty-board) 
         (filter 
          (lambda (all-queens) (safe? column all-queens)) 
          (flatmap 
           (lambda (queens-already-placed) 
             (map (lambda (row) 
                    (add-queen row column queens-already-placed)) 
                  row-numbers)) 
           (safely-place-queen-in-column (- column 1)))))) 
  
   (safely-place-queen-in-column board-size)) 
  
  
 ;; Usage: 
 (queens 8) 
  

dudrenov

technically the get-queen-in-column procedure with this particular solution is not needed, since the car of the list of columns passed to safe? will be the newest column. also at that point it should be enough to pass the cdr of all-queens to map in safe?


pj

Here's a solution using a different representation of positions.

 ;; 8 Queens Problem  
  
 ;; Representation of Board Positions 
 ;; 
 ;; Board positions are represented by a list whose length is the  
 ;; board size. For example, a board size of four would have a  
 ;; list with four elements. Each element is the row number of  
 ;; the queen on that column. 
 ;; For example,  
 ;;     (list 1 1 1 1) represents positions of four queens across  
 ;;                    the top row, 
 ;;     (list 1 2 3 4) represents positions of four queens on a  
 ;;                    diagonal from the upper left corner to the 
 ;;                    lower right corner, and 
 ;;     (list 2 4 1 3) is a solution to the 4 Queens problem. 
 ;; Note that this representation allows only one queen per column 
 ;; so there is no need to check if a queen is subject to a 
 ;; column attack. 
 ;; 
 ;; A set of board positions is represented as a list of positions.  
 ;; For example, (list (list 1 1 1 1) (list 1 2 3 4) (list 2 4 1 3)) 
 ;; is the set of positions given above. 
  
 ;; Supporting Functions 
  
 (define (enumerate-interval low high) 
   (if (> low high) 
       '() 
       (cons low (enumerate-interval (+ low 1) high)))) 
  
 (define (filter predicate sequence) 
   (cond ((null? sequence) '()) 
         ((predicate (car sequence)) 
          (cons (car sequence) 
                (filter predicate (cdr sequence)))) 
         (else (filter predicate (cdr sequence))))) 
  
 (define (accumulate op initial sequence) 
   (if (null? sequence) 
       initial 
       (op (car sequence) 
           (accumulate op initial (cdr sequence))))) 
  
 (define (flatmap proc seq) 
   (accumulate append '() (map proc seq))) 
  
 ;; Main Function                  
  
 (define (queens board-size) 
   (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)) 
  
 (define empty-board '()) 
  
 ;; Adds a queen on the kth column on the new-row 
 (define (adjoin-position new-row k rest-of-queens) 
   (append rest-of-queens (list new-row))) 
  
 ;; Is the new queen safe? 
 (define (safe? k positions) 
   (and (safe-row? k positions) 
        (safe-diagonal? k positions))) 
  
 ;; 
 ;;  The rest of these functions support (safe? ...). 
 ;; 
  
 ;; Is the new queen safe from row attacks? 
 ;; Uses MIT scheme function boolean/or which does the expected 
 ;; or'ing of booleans. 
 (define (safe-row? k positions) 
   (not (accumulate boolean/or false (same-row? k positions)))) 
  
 ;; Is the new queen safe from diagonal attacks? 
 (define (safe-diagonal? k positions) 
   (not (accumulate boolean/or false (diagonal? k positions)))) 
  
 ;; Does a pair-wise test for same row between the queen on the  
 ;; kth column and each of the other queens. 
 (define (same-row? k positions) 
   (map (lambda (pair) 
          (= (get-row positions (car pair))  
             (get-row positions (cadr pair)))) 
        (last-column-pairs k))) 
  
 ;; Does a pair-wise test for diagonality between the kth queen  
 ;; and each of the others. Diagonals have a slope of +/- 1 =  
 ;; abs(column2-column1)/abs(row2-row1). 
 (define (diagonal? k positions) 
   (map (lambda (pair) 
          (= (abs (- (get-row positions (car pair))  
                     (get-row positions (cadr pair)))) 
             (abs (- (car pair) (cadr pair))))) 
        (last-column-pairs k))) 
  
 ;; Gets the row number of the queen on the column of the positions 
 ;; Valid columns range from 1 to board-size 
 (define (get-row positions column) 
   (if (= column 1) 
       (car positions) 
       (get-row (cdr positions) (- column 1)))) 
  
 ;; Creates a list of pairs of column indexes consisting of the kth 
 ;; column and all other columns 
 (define (last-column-pairs k) 
   (map (lambda (j) (list j k)) 
        (enumerate-interval 1 (- k 1)))) 
  
 ;; Tests 
  
  (define (assert-true expected-true message) 
    (newline)(display message) 
    (cond (expected-true  
           'PASSED) 
          (else 'FAILED))) 
  
  (define (assert-false expected-false message) 
    (newline)(display message) 
    (cond ((not expected-false)  
           'PASSED) 
          (else 'FAILED))) 
  
 (assert-false (safe? 4 (list 2 4 1 1))  
               "testing safe? (list 2 4 1 1)") 
  
 (assert-false (safe? 4 (list 2 4 1 2))  
               "testing safe? (list 2 4 1 2)") 
  
 (assert-true (safe? 4 (list 2 4 1 3))  
              "testing safe? (list 2 4 1 3)") 
  
 (assert-false (safe? 4 (list 2 4 1 4))  
               "testing safe? (list 2 4 1 4)") 
  
 ;; End of Tests 
  
 ;; Run solution 
 (queens 8) 
  
  
  

Here's a slightly different take on the safe? testing. I've passed on the functions already described in sicp

 ;; a solution with a recursive test based on the number of columns away the  
 ;; queen being tested against is 
 ;; if the distance horizontally is the same as the vertical difference it's not  
 ;; valid 
 (define (queens board-size) 
   (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)) 
  
  
 (define empty-board '()) 
  
  
 (define (adjoin-position new-row k rest-of-queens) 
   (append (list new-row) rest-of-queens)) 
  
  
 (define (safe? k positions) 
   (check-safe 
    (car positions) 
    1 
    (cdr positions))) 
  
  
 ;; Check the queens column position against that of all other columns 
 ;; One if vertical distance = horizontal distance it's a diagonal hit 
 (define (check-safe position distance cols) 
   (cond ((null? cols) #t) 
         ((= (car cols) position) #f) 
         ((= (- (car cols) distance) position) #f) 
         ((= (+ (car cols) distance) position) #f) 
         (else (check-safe position (+ distance 1) (cdr cols))))) 
        

Another version for safe?

 ;; returns #t if first queen in 'positions is safe 
 ;; queen is safe if no other queen is in the same row, diagonal or antidiagonal 
 ;; diagonal = row + column 
 ;; anti-diagonal = row - column 
 (define (safe? k positions) 
     (if (null? positions) 
         #t 
         (let ([diags      (map + positions (range 0 (- k 1)))] 
               [anti-diags (map - positions (range 0 (- k 1)))]) 
             (and (not (member (car positions) (cdr positions))) 
                  (not (member (car diags) (cdr diags))) 
                  (not (member (car anti-diags) (cdr anti-diags))))))) 
 (define empty-board nil) 
  
 ;; I have choosed to append the new position in front of the list 
 ;; that way we will have the columns in the reverse order 
 ;; which is not q problem as we can solve it with this simple hack: 
 ;; (map reverse (queens 4)) 
 (define (adjoin-position new-row k rest-of-queens) 
     (cons (list k new-row) rest-of-queens)) 
  
 (define (safe? k positions) 
     (define (safe-row?) 
         (null? (filter (lambda (pos) (= (cadr pos) (cadar positions))) (cdr positions)))) 
     (define (safe-diag?) 
         (null? (filter (lambda (pos) (= (abs (- (caar positions) (car pos))) (abs (- (cadar positions) (cadr pos))))) (cdr positions)))) 
     (and (safe-row?) (safe-diag?))) 




caesarjuly

chekkal's solution is concise
but I think there is another interesting way to get 'safe?'
this is my solution for 'safe?'

 ;;first step:use map to make every items in 'positions' to #t or #f 
 ;;then just use 'accumulate' to unite the #t or #f 
 ;;and I think 'k' is useless 
 (define (safe? k positions) 
   (accumulate  
      (lambda (x y) (and x y))  
      #t  
      (map (lambda (x)  
              (if (or (= (caar positions) (car x))  
                      (= (abs (- (caar positions) (car x)))  
                         (abs (- (cadar positions) (cadr x))))) 
                  #f 
                  #t))  
           (cdr positions)))) 

atrika

good exercise

 ;; i did not put the other procedures which you can get from the book 
 (define (make-queen x y) (cons x y)) 
  
 (define (x-queen q) (car q)) 
  
 (define (y-queen q) (cdr q)) 
  
 (define (queen-collides? q1 q2) 
   (or (= (x-queen q1) (x-queen q2)) 
       (= (y-queen q1) (y-queen q2)) 
       (= (abs (- (x-queen q1) (x-queen q2))) 
          (abs (- (y-queen q1) (y-queen q2)))))) 
  
 (define (universal-qt? predicate? sequence) 
   (if (null? sequence) 
       #t 
       (if (predicate? (car sequence)) 
           (universal-qt? predicate? (cdr sequence)) 
           #f))) 
  
 (define (get-elem is-elem? sequence) 
   (if (null? sequence) 
       #f 
       (if (is-elem? (car sequence)) 
           (car sequence) 
           (get-elem is-elem? (cdr sequence))))) 
  
 (define (safe? k positions) 
   (let ((picked (get-elem (lambda (q) (= k (x-queen q)))  
                           positions))) 
     (universal-qt? (lambda (queen)  
                      (not (queen-collides?  
                            picked  
                            queen))) 
                    (remove picked positions)))) 
  
  
 (define (adjoin-position new-row k rest-of-queens) 
   (cons (make-queen k new-row) rest-of-queens))