mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
50 lines
1.4 KiB
Scheme
50 lines
1.4 KiB
Scheme
(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)))
|
|
|
|
(define (enumerate-interval low high)
|
|
(if (> low high)
|
|
'()
|
|
(cons low (enumerate-interval (+ low 1) high))))
|
|
|
|
(define empty-board '())
|
|
|
|
(define (rest bs k rest-of-queens)
|
|
(map (lambda (new-row)
|
|
(adjoin-position new-row k rest-of-queens))
|
|
(enumerate-interval 1 bs)))
|
|
|
|
(define (queen-cols board-size k)
|
|
(if (= k 0)
|
|
(list empty-board)
|
|
(filter (lambda (positions) (safe? k positions))
|
|
(flatmap (lambda (r) (rest board-size k r))
|
|
(queen-cols board-size (- k 1))))))
|
|
|
|
(define (queens board-size)
|
|
(queen-cols board-size board-size))
|
|
|
|
(define (adjoin-position new-row k rest-of-queens)
|
|
(append rest-of-queens (list new-row)))
|
|
|
|
(define (safe? k positions)
|
|
(let ((new (car (last-pair positions)))
|
|
(bottom (car positions)))
|
|
(cond ((= k 1) #t)
|
|
((= new bottom) #f)
|
|
((or (= new (- bottom (- k 1))) (= new (+ bottom (- k 1)))) #f)
|
|
(else (safe? (- k 1) (cdr positions))))))
|
|
|
|
(test (queens 4) '((2 4 1 3) (3 1 4 2)))
|