43 lines
1.8 KiB
Racket
43 lines
1.8 KiB
Racket
#lang racket
|
|
|
|
;; A quick `amb' implementation
|
|
(define fails '())
|
|
(define (fail) (if (pair? fails) ((car fails)) (error "no more choices!")))
|
|
(define (amb xs)
|
|
(let/cc k (set! fails (cons k fails)))
|
|
(if (pair? xs) (begin0 (car xs) (set! xs (cdr xs)))
|
|
(begin (set! fails (cdr fails)) (fail))))
|
|
(define (assert . conditions) (when (memq #f conditions) (fail)))
|
|
|
|
;; Convenient macro for definining problem items
|
|
(define-syntax-rule (with: all (name ...) #:in choices body ...)
|
|
(let* ([cs choices] [name (amb cs)] ... [all `([,name name] ...)]) body ...))
|
|
|
|
;; ===== problem translation starts here =====
|
|
|
|
;; Baker, Cooper, Fletcher, Miller, and Smith live on different floors
|
|
;; of an apartment house that contains only five floors.
|
|
(with: residents [Baker Cooper Fletcher Miller Smith] #:in (range 1 6)
|
|
;; Some helpers
|
|
(define (on-top x) (for/and ([y residents]) (x . >= . (car y))))
|
|
(define (on-bottom x) (for/and ([y residents]) (x . <= . (car y))))
|
|
(define (adjacent x y) (= 1 (abs (- x y))))
|
|
(assert
|
|
;; ... live on different floors ...
|
|
(assert (= 5 (length (remove-duplicates (map car residents)))))
|
|
;; Baker does not live on the top floor.
|
|
(not (on-top Baker))
|
|
;; Cooper does not live on the bottom floor.
|
|
(not (on-bottom Cooper))
|
|
;; Fletcher does not live on either the top or the bottom floor.
|
|
(not (on-top Fletcher))
|
|
(not (on-bottom Fletcher))
|
|
;; Miller lives on a higher floor than does Cooper.
|
|
(> Miller Cooper)
|
|
;; Smith does not live on a floor adjacent to Fletcher's.
|
|
(not (adjacent Smith Fletcher))
|
|
;; Fletcher does not live on a floor adjacent to Cooper's.
|
|
(assert (not (adjacent Fletcher Cooper))))
|
|
;; Where does everyone live?
|
|
(printf "Solution:\n")
|
|
(for ([x (sort residents > #:key car)]) (apply printf " ~a. ~a\n" x)))
|