learning-sicp

My embarrassing half assed SICP run.
git clone https://kaka.farm/~git/learning-sicp
Log | Files | Refs

exercise-42.scm (3695B)

      1 (define-library (sicp solutions chapter-2 exercise-42)
      2   (import (scheme base)
      3           (srfi :1)
      4           (only (sicp utils) flatmap))
      5   (export safe? queens make-position)
      6 
      7   (begin
      8     (define (make-position row column)
      9       (cons row column))
     10 
     11     (define (position-row position)
     12       (car position))
     13 
     14     (define (position-column position)
     15       (cdr position))
     16 
     17     (define (adjoin-position row column rest-of-queens)
     18       (cons (make-position row column)
     19             rest-of-queens))
     20 
     21     (define empty-board '()) ;; queens 0 will return [[]].
     22 
     23     (define (threatening-pair? queen-a-position queen-b-position)
     24       (define a-row (position-row queen-a-position))
     25       (define b-row (position-row queen-b-position))
     26 
     27       (define a-column (position-column queen-a-position))
     28       (define b-column (position-column queen-b-position))
     29 
     30       (define rows-equal (= a-row
     31                             b-row))
     32 
     33       (define on-same-diagonal (= (abs (- a-row
     34                                           b-row))
     35                                   (abs (- a-column
     36                                           b-column))))
     37 
     38       (or rows-equal
     39           on-same-diagonal))
     40 
     41     "
     42  Q
     43   Q
     44    Q
     45 
     46 Q1 = (2, 1)
     47 Q2 = (3, 2)
     48 Q1 - Q2 = (2 - 3, 1 - 2)
     49 = (-1, -1)
     50 Q3 = (4, 3)
     51 Q1 - Q3 = (2 - 4, 1 - 3)
     52 = (-2, -2)
     53 
     54    Q
     55   Q
     56  Q
     57 Q
     58 
     59 Q1 = (4, 1)
     60 Q2 = (3, 2)
     61 Q3 = (2, 3)
     62 
     63 Q1 - Q2 = (4 - 3, 1 - 2)
     64 = (1, -1)
     65 Q1 - Q3 = (4 - 2, 1 - 3)
     66 = (2, -2)
     67 Q1 - Q4 = (4 - 1, 1 - 4)
     68 = (3, -3)
     69 "
     70 
     71 
     72     (define (safe? our-column board)
     73       (define our-row (position-row (car board)))
     74 
     75       (if (null?
     76            (filter
     77             (lambda (position)
     78               (threatening-pair?
     79                (make-position our-row
     80                               our-column)
     81                position))
     82             (cdr board)))
     83           #t
     84           #f))
     85 
     86     (define (queens board-size)
     87       (define (queen-cols k)
     88         (if (= k 0)
     89             (list empty-board)
     90             (filter
     91              (lambda (positions)
     92                (safe? k
     93                       positions))
     94              (flatmap
     95               (lambda (rest-of-queens)
     96                 (map (lambda (new-row)
     97                        (adjoin-position
     98                         new-row
     99                         k
    100                         rest-of-queens))
    101                      (enumerate-interval
    102                       1
    103                       board-size)))
    104               (queen-cols (- k 1))))))
    105       (queen-cols board-size))
    106 
    107     (define (display-board board n)
    108       (define sorted-board
    109         (sort board
    110               (lambda (a b)
    111                 (or
    112                  (< (position-row a)
    113                     (position-row b))
    114                  ;; (< (position-column a)
    115                  ;;    (position-column b))
    116                  ))))
    117       '(define sorted-board board)
    118 
    119       (define (display-row column n)
    120         (pretty-print (list column n))
    121         (cond
    122          ((zero? n) '())
    123          ((= column n)
    124           (display "Q\n")
    125           (display-row column (- n 1)))
    126          (else (display ".")
    127                (display-row column (- n 1)))))
    128 
    129       (for-each
    130        (lambda (position)
    131          (display-row
    132           (position-column position)
    133           n))
    134        sorted-board))
    135 
    136     '(for-each (lambda (board)
    137                  (display-board board
    138                                 (reduce
    139                                  (lambda (x y)
    140                                    (max (position-column x)
    141                                         (position-column y)))
    142                                  0
    143                                  board))
    144                  (pretty-print board))
    145                (flatmap queens
    146                         (enumerate-interval 1 8)))))