8 queens puzzle solver

8_queens.rkt

#lang racket

(define-syntax-rule (let1 a b body ...)
(let ((a b)) body ...))

(require rackunit)

(define (diag-asc q)
  (- (car q) (cdr q)))

(check-equal? (diag-asc '(1 . 1)) (diag-asc '(8 . 8)))
(check-not-equal? (diag-asc '(1 . 8)) (diag-asc '(8 . 1)))

(define (diag-desc q)
  (+ (car q) (cdr q)))

(check-not-equal? (diag-desc '(1 . 1)) (diag-desc '(8 . 8)))
(check-equal? (diag-desc '(1 . 8)) (diag-desc '(8 . 1)))

(define (free q1 q2)
  (not
   (or
    (equal? (car q1) (car q2))
    (equal? (cdr q1) (cdr q2))
    (equal? (diag-asc q1) (diag-asc q2))
    (equal? (diag-desc q1) (diag-desc q2)))))

(check free '(1 . 1) '(2 . 3))
(check-false (free '(1 . 1) '(1 . 8)))
(check-false (free '(1 . 1) '(8 . 1)))
(check-false (free '(1 . 1) '(8 . 8)))
(check-false (free '(1 . 8) '(8 . 1)))

(define (ok-queen-game q game)
  (andmap (λ (_) (free q _)) game))

(check ok-queen-game '(1 . 1) '())

(define (ok game)
  (if (null? game)
      #t
      (and (ok-queen-game (car game) (cdr game))
           (ok (cdr game)))))

(define (next q)
  (if (< (cdr q) 8)
      (cons (car q) (+ 1 (cdr q)))
      (if (< (car q) 8)
          (cons (+ 1 (car q)) 1)
          '())))

(check-equal? (next '(1 . 1)) '(1 . 2))
(check-equal? (next '(1 . 8)) '(2 . 1))
(check-equal? (next '(8 . 8)) '())

; a game is a list of 8 queens

(define (place-queen q game)
  (let1 new-game (cons q game)
        (if (ok new-game)
            new-game
            (let1 nq (next q)
                  (if (null? nq)
                      (place-queen '(1 . 1) (next-ok-game game))
                      (place-queen nq game))))))

(check-equal? (place-queen '(1 . 1) (reverse '((1 . 1) (2 . 3) (3 . 5) (4 . 7))))
              '((5 . 2) (4 . 7) (3 . 5) (2 . 3) (1 . 1)))

(define (next-ok-game game)
  (println game)
  (let1 nq (next (car game))
        (if (null? nq)
            (place-queen '(1 . 1) (next-ok-game (cdr game)))
            (place-queen nq (cdr game)))))

(check-equal? (next-ok-game '((5 . 4) (4 . 2) (3 . 5) (2 . 3) (1 . 1)))
              '((5 . 8) (4 . 2) (3 . 5) (2 . 3) (1 . 1)))
                            

(define (next-game game)
  (let1 nq (next (car game))
        (if (null? nq)
            (cons '(1 . 1) (next-game (cdr game)))
            (cons nq (cdr game)))))

(define (solve-iter game)
  (println game)
  (if (ok game)
      (if (equal? 8 (length game))
          game
          (solve-iter (place-queen '(1 . 1) game)))
      (solve-iter (next-game game))))

(define (n-times n x)
(build-list n (lambda (i) x)))

(define init-game (n-times 8 '(1 . 1)))


;> (solve-iter '((1 . 1)))
;'((1 . 1))
;'((2 . 3) (1 . 1))
;'((3 . 5) (2 . 3) (1 . 1))
;'((4 . 2) (3 . 5) (2 . 3) (1 . 1))
;'((5 . 4) (4 . 2) (3 . 5) (2 . 3) (1 . 1))
;...
; 25946 tries
;...
;
;'((8 . 4) (7 . 2) (6 . 7) (5 . 3) (4 . 6) (3 . 8) (2 . 5) (1 . 1))