99 lines
2.5 KiB
Scheme
99 lines
2.5 KiB
Scheme
|
|
(define allqueens
|
|
(lambda (n doneproc)
|
|
(letrec
|
|
((diag1
|
|
(lambda (board col)
|
|
(if (null? board) '()
|
|
(cons (+ col (car board))
|
|
(diag1 (cdr board) (+ col 1))))))
|
|
(diag2
|
|
(lambda (board col)
|
|
(if (null? board) '()
|
|
(cons (- col (car board))
|
|
(diag2 (cdr board) (+ col 1))))))
|
|
(consistent?
|
|
(lambda (board col new)
|
|
(not
|
|
(or (member new board)
|
|
(member (+ col new)
|
|
(diag1 board 1))
|
|
(member (- col new)
|
|
(diag2 board 1))))))
|
|
(check
|
|
(lambda (board col)
|
|
(if (> col n) (doneproc board)
|
|
(for-each
|
|
(lambda (row)
|
|
(if (consistent? board col row)
|
|
(check (append board (list row))
|
|
(+ 1 col))))
|
|
(list-n n))))))
|
|
(check '() 1))))
|
|
|
|
(define queens
|
|
(lambda (n)
|
|
(letrec
|
|
((y-reflect reverse)
|
|
(rotate
|
|
(lambda (board)
|
|
(map
|
|
(lambda (row)
|
|
(- (+ 1 n) (length (member row board))))
|
|
(list-n n))))
|
|
(symmetries
|
|
(lambda (board)
|
|
(list
|
|
board
|
|
(rotate board)
|
|
(rotate (rotate board))
|
|
(rotate (rotate (rotate board)))
|
|
(y-reflect board)
|
|
(rotate (y-reflect board))
|
|
(rotate (rotate (y-reflect board)))
|
|
(rotate (rotate (rotate (y-reflect board)))))))
|
|
(result '())
|
|
(new?
|
|
(lambda (rlist sol)
|
|
(if (null? rlist) #t
|
|
(if (member sol (car rlist)) #f
|
|
(new? (cdr rlist) sol))))))
|
|
(allqueens
|
|
n
|
|
(lambda (sol)
|
|
(if (new? result sol)
|
|
(set! result (cons (symmetries sol) result)))))
|
|
(map car result))))
|
|
|
|
(define queenspic
|
|
(lambda (n)
|
|
(let* ((scale 30) (radius (/ scale 3)))
|
|
(for-each
|
|
(lambda (sol)
|
|
(letrec
|
|
((drawqueens
|
|
(lambda (pos sol)
|
|
(if (not (null? sol))
|
|
(begin
|
|
(draw-move pos (- (* (car sol) scale) (/ scale 2)))
|
|
(fill-circle radius)
|
|
(drawqueens (+ pos scale) (cdr sol))))))
|
|
(drawlines
|
|
(lambda (m)
|
|
(draw-move 0 (* m scale))
|
|
(draw-line (* n scale) (* m scale))
|
|
(draw-move (* m scale) 0)
|
|
(draw-line (* m scale) (* n scale))
|
|
(if (not (zero? m))
|
|
(drawlines (- m 1))))))
|
|
(draw-color 255 0 0)
|
|
(drawqueens 15 sol)
|
|
(draw-color 0 0 0)
|
|
(drawlines n)
|
|
(draw-show)))
|
|
(queens n)))))
|
|
|
|
(queenspic 5)
|
|
|
|
|