335 lines
12 KiB
Scheme
335 lines
12 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/lib-amb.scm")
|
|
|
|
(define (require p)
|
|
(if (not p) (amb)))
|
|
|
|
(define (an-element-of items)
|
|
(require (not (null? items)))
|
|
(amb (car items) (an-element-of (cdr items))))
|
|
|
|
(define (an-integer-starting-from n)
|
|
(amb n (an-integer-starting-from (+ n 1))))
|
|
|
|
(display "\nex-4.35 - an-integer-between\n")
|
|
|
|
(define (an-integer-between a b)
|
|
(require (<= a b))
|
|
(amb a (an-integer-between (+ a 1) b)))
|
|
|
|
(define (a-pythagorean-triple-between low high)
|
|
(let ((i (an-integer-between low high)))
|
|
(let ((j (an-integer-between i high)))
|
|
(let ((k (an-integer-between j high)))
|
|
(require (= (+ (* i i) (* j j)) (* k k)))
|
|
(list i j k)))))
|
|
|
|
(display "[done]\n")
|
|
|
|
(display "\nex-4.36 - all-pythagorean-triples\n")
|
|
|
|
; If we replace an-integer-between with an-integer-starting-from the variables
|
|
; i and j will stay at their initial value 1 while k will increment endlessly.
|
|
; Hence, only triplets of the form (1 1 n) will be generated.
|
|
|
|
(define (all-pythagorean-triples)
|
|
(let ((i (an-integer-starting-from 1)))
|
|
(let ((j (an-integer-starting-from i)))
|
|
(let ((k (an-integer-starting-from j)))
|
|
(require (= (+ (* i i) (* j j)) (* k k)))
|
|
(list i j k)))))
|
|
|
|
(define (all-pythagorean-triples)
|
|
(let ((k (an-integer-starting-from 1)))
|
|
(let ((i (an-integer-between 1 k)))
|
|
(let ((j (an-integer-between i k)))
|
|
(require (= (+ (* i i) (* j j)) (* k k)))
|
|
(list i j k)))))
|
|
|
|
; Note: It would be more efficient to choose to integers and then calculate if
|
|
; (+ (* i i) (* j j)) is a perfect square.
|
|
|
|
(display "[done]\n")
|
|
|
|
(display "\nex-4.37 - more-efficient-pythagorean-triples\n")
|
|
|
|
(define (a-pythagorean-triple-between low high)
|
|
(let ((i (an-integer-between low high))
|
|
(hsq (* high high)))
|
|
(let ((j (an-integer-between i high)))
|
|
(let ((ksq (+ (* i i) (* j j))))
|
|
(require (>= hsq ksq))
|
|
(let ((k (sqrt ksq)))
|
|
(require (integer? k))
|
|
(list i j k))))))
|
|
|
|
; This implementation uses my note from the previous exercises. Computing sqrt
|
|
; and checking for integer is faster ultimately, because the majority of
|
|
; combinations are not solutions.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.38 - multiple-dwelling\n")
|
|
|
|
(define (distinct? items)
|
|
(cond ((null? items) true)
|
|
((null? (cdr items)) true)
|
|
((member (car items) (cdr items)) false)
|
|
(else (distinct? (cdr items)))))
|
|
|
|
(define (multiple-dwelling)
|
|
(let ((baker (amb 1 2 3 4 5))
|
|
(cooper (amb 1 2 3 4 5))
|
|
(fletcher (amb 1 2 3 4 5))
|
|
(miller (amb 1 2 3 4 5))
|
|
(smith (amb 1 2 3 4 5)))
|
|
(require (distinct? (list baker cooper fletcher miller smith)))
|
|
(require (not (= baker 5)))
|
|
(require (not (= cooper 1)))
|
|
(require (not (= fletcher 5)))
|
|
(require (not (= fletcher 1)))
|
|
(require (> miller cooper))
|
|
(require (not (= (abs (- smith fletcher)) 1))) ; adjacent floors constraint
|
|
(require (not (= (abs (- fletcher cooper)) 1)))
|
|
(list (list 'baker baker)
|
|
(list 'cooper cooper)
|
|
(list 'fletcher fletcher)
|
|
(list 'miller miller)
|
|
(list 'smith smith))))
|
|
|
|
(my-assert (multiple-dwelling)
|
|
'((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
|
|
|
|
(define (multiple-dwelling-removed)
|
|
(let ((baker (amb 1 2 3 4 5))
|
|
(cooper (amb 1 2 3 4 5))
|
|
(fletcher (amb 1 2 3 4 5))
|
|
(miller (amb 1 2 3 4 5))
|
|
(smith (amb 1 2 3 4 5)))
|
|
(require (distinct? (list baker cooper fletcher miller smith)))
|
|
(require (not (= baker 5)))
|
|
(require (not (= cooper 1)))
|
|
(require (not (= fletcher 5)))
|
|
(require (not (= fletcher 1)))
|
|
(require (> miller cooper))
|
|
;; (require (not (= (abs (- smith fletcher)) 1))) ; adjacent floors constraint
|
|
(require (not (= (abs (- fletcher cooper)) 1)))
|
|
(list (list 'baker baker)
|
|
(list 'cooper cooper)
|
|
(list 'fletcher fletcher)
|
|
(list 'miller miller)
|
|
(list 'smith smith))))
|
|
|
|
; There are five solutions when the adjacent floor constraint for smith and
|
|
; fletcher is removed.
|
|
|
|
(my-assert (length (set-of (multiple-dwelling-removed))) 5)
|
|
|
|
(display "\nex-4.39 - multiple-dwelling-ordering\n")
|
|
|
|
; The ordering does not matter because the interpreter first evaluates all ambs
|
|
; and then runs the checks. The interpreter will check all combinations even if
|
|
; they cannot yield a possible solution, such as (fletcher 1). To avoid this one
|
|
; would have to interleave the amb expression and the checks.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(define (repeat proc n)
|
|
(if (= n 0)
|
|
't
|
|
(begin
|
|
(proc)
|
|
(repeat proc (- n 1)))))
|
|
|
|
(let ((start-time (runtime)))
|
|
(repeat multiple-dwelling 10)
|
|
(display "[default = ")
|
|
(display (- (runtime) start-time))
|
|
(display "]\n"))
|
|
|
|
(display "\nex-4.40 - multiple-dwelling-improved\n")
|
|
|
|
(define (multiple-dwelling)
|
|
(let ((baker (amb 1 2 3 4 5)))
|
|
(require (not (= baker 5)))
|
|
(let ((cooper (amb 1 2 3 4 5)))
|
|
(require (distinct? (list baker cooper)))
|
|
(require (not (= baker cooper)))
|
|
(require (not (= cooper 1)))
|
|
(let ((fletcher (amb 1 2 3 4 5)))
|
|
(require (distinct? (list baker cooper fletcher)))
|
|
(require (not (= cooper fletcher)))
|
|
(require (not (= fletcher 5)))
|
|
(require (not (= fletcher 1)))
|
|
(let ((miller (amb 1 2 3 4 5)))
|
|
(require (distinct? (list baker cooper fletcher miller)))
|
|
(require (not (= fletcher miller)))
|
|
(require (> miller cooper))
|
|
(require (not (= (abs (- fletcher cooper)) 1)))
|
|
(let ((smith (amb 1 2 3 4 5)))
|
|
(require (distinct? (list baker cooper fletcher miller smith)))
|
|
(require (not (= (abs (- smith fletcher)) 1)))
|
|
(list (list 'baker baker)
|
|
(list 'cooper cooper)
|
|
(list 'fletcher fletcher)
|
|
(list 'miller miller)
|
|
(list 'smith smith))))))))
|
|
|
|
(my-assert (multiple-dwelling)
|
|
'((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
|
|
|
|
(let ((start-time (runtime)))
|
|
(repeat multiple-dwelling 10)
|
|
(display "[improved = ")
|
|
(display (- (runtime) start-time))
|
|
(display "]\n"))
|
|
|
|
(display "\nex-4.41 - multiple-dwelling-ordinary\n")
|
|
|
|
; Appand all ys to xs.
|
|
(define (append-all xs ys)
|
|
(map (lambda (y) (append xs (list y))) ys))
|
|
|
|
(define (available-floors dwelling)
|
|
(filter (lambda (x) (not (memq x dwelling))) '(1 2 3 4 5)))
|
|
|
|
(define (flatten xss)
|
|
(if (null? xss)
|
|
xss
|
|
(if (pair? (car (car xss)))
|
|
(reduce append '() xss)
|
|
xss)))
|
|
|
|
(define (multiple-dwelling-ordinary)
|
|
(define baker first)
|
|
(define cooper second)
|
|
(define fletcher third)
|
|
(define miller fourth)
|
|
(define smith fifth)
|
|
|
|
(define (dwellings dwelling constraints)
|
|
(if (null? constraints)
|
|
dwelling
|
|
(let ((new-dwellings (filter (car constraints)
|
|
(append-all dwelling (available-floors dwelling)))))
|
|
(flatten (filter
|
|
(lambda (x) (not (null? x)))
|
|
(map (lambda (dwelling) (dwellings dwelling (cdr constraints))) new-dwellings))))))
|
|
|
|
(define constraints
|
|
(list
|
|
(lambda (dwelling) (not (= (baker dwelling) 5)))
|
|
(lambda (dwelling) (not (= (cooper dwelling) 1)))
|
|
(lambda (dwelling) (and (not (= (fletcher dwelling) 5))
|
|
(not (= (fletcher dwelling) 1))))
|
|
(lambda (dwelling) (and (> (miller dwelling) (cooper dwelling))
|
|
(not (= (abs (- (fletcher dwelling) (cooper dwelling))) 1))))
|
|
(lambda (dwelling) (not (= (abs (- (smith dwelling) (fletcher dwelling))) 1)))
|
|
;(lambda (dwelling) #t) ; no adjacent floor constraint for smith and fletcher
|
|
))
|
|
(define (tag-result xs)
|
|
(map (lambda (name number) (list name number))
|
|
'(baker cooper fletcher miller smith)
|
|
xs))
|
|
(map tag-result (dwellings '() constraints)))
|
|
|
|
(my-assert (multiple-dwelling)
|
|
(car (multiple-dwelling-ordinary)))
|
|
|
|
(display "\nex-4.42 - liars-puzzle\n")
|
|
|
|
(define (xor p q)
|
|
(require (or (and p (not q)) (and (not p) q))))
|
|
|
|
(define (liars-puzzle)
|
|
(let ((ethel (an-integer-between 1 5))
|
|
(joan (an-integer-between 1 5)))
|
|
(xor (= ethel 1) (= joan 2))
|
|
(xor (= joan 3) (= ethel 5))
|
|
(let ((kitty (an-integer-between 1 5))
|
|
(betty (an-integer-between 1 5))
|
|
(mary (an-integer-between 1 5)))
|
|
(xor (= kitty 2) (= betty 3))
|
|
(xor (= kitty 2) (= mary 4))
|
|
(xor (= mary 4) (= betty 1))
|
|
(require (distinct? (list kitty betty ethel joan mary)))
|
|
(map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary)))))
|
|
|
|
(display (liars-puzzle)) (newline)
|
|
|
|
; My solution to this problem was previously wrong because I didn't check for
|
|
; the either or conditions at the same step of the search. Consequently, a true
|
|
; statement of one student could be a false statement of the other student.
|
|
; This cannot happen when we check at the same time.
|
|
|
|
(display "\nex-4.43 - lornas-father\n")
|
|
|
|
; (daughter father yacht)
|
|
(define daughter first)
|
|
(define father second)
|
|
(define yacht third)
|
|
|
|
(define (lornas-father)
|
|
(let* ((moore-daughter (amb 'mary-ann))
|
|
(moore-yacht (amb 'lorna))
|
|
(moore (list moore-daughter 'moore moore-yacht)))
|
|
(let* ((downing-daughter (amb 'gabrielle 'lorna 'rosalind))
|
|
(downing-yacht (amb 'melissa))
|
|
(downing (list downing-daughter 'downing downing-yacht)))
|
|
(require (distinct? (list moore-daughter downing-daughter)))
|
|
(require (distinct? (list moore-yacht downing-yacht)))
|
|
(require (distinct? (list downing-yacht downing-daughter)))
|
|
(let* ((hall-daughter (amb 'gabrielle 'lorna 'melissa))
|
|
(hall-yacht (amb 'rosalind))
|
|
(hall (list hall-daughter 'hall hall-yacht)))
|
|
(require (distinct? (list hall-yacht hall-daughter)))
|
|
(require (distinct? (list moore-daughter downing-daughter hall-daughter)))
|
|
(require (distinct? (list moore-yacht downing-yacht hall-yacht)))
|
|
(let* ((barnacle-daughter (amb 'melissa))
|
|
(barnacle-yacht (amb 'gabrielle))
|
|
(barnacle (list barnacle-daughter 'barnacle barnacle-yacht)))
|
|
(require (distinct? (list barnacle-yacht barnacle-daughter)))
|
|
(require (distinct? (list moore-daughter downing-daughter hall-daughter barnacle-daughter)))
|
|
(require (distinct? (list moore-yacht downing-yacht hall-yacht barnacle-yacht)))
|
|
(let* ((parker-daughter (amb 'gabrielle 'lorna 'rosalind 'melissa))
|
|
(parker-yacht (amb 'mary-ann 'gabrielle 'lorna 'rosalind 'melissa))
|
|
(parker (list parker-daughter 'parker parker-yacht)))
|
|
(require (distinct? (list parker-yacht parker-daughter)))
|
|
(require (distinct? (list moore-daughter downing-daughter hall-daughter barnacle-daughter parker-daughter)))
|
|
(require (distinct? (list moore-yacht downing-yacht hall-yacht barnacle-yacht parker-yacht)))
|
|
(require (eq? parker-daughter (yacht (assoc 'gabrielle (list moore downing hall barnacle parker)))))
|
|
(father (assoc 'lorna (list moore downing hall barnacle parker)))))))))
|
|
|
|
(my-assert (lornas-father) 'downing)
|
|
|
|
(display "\nex-4.44 - eight-queens\n")
|
|
|
|
; Copied from ex-2_33-43.scm
|
|
(define (safe? board)
|
|
(define (valid-position row diag board)
|
|
(if (null? board)
|
|
#t
|
|
(let ((cur_row (car board)))
|
|
(if (or (= row cur_row) ; same row
|
|
(= (+ row diag) cur_row) ; upper right diagonal
|
|
(= (- row diag) cur_row)) ; lower left diagonal
|
|
#f
|
|
(valid-position row (+ diag 1) (cdr board))))))
|
|
(valid-position (car board) 1 (cdr board)))
|
|
|
|
(define (queens)
|
|
(define (positions)
|
|
(amb 1 2 3 4 5 6 7 8))
|
|
(define (queens-iter board remaining)
|
|
(if (= remaining 0)
|
|
board
|
|
(let* ((current-queen (positions))
|
|
(new-board (cons current-queen board)))
|
|
(require (safe? new-board))
|
|
(queens-iter new-board (- remaining 1)))))
|
|
(queens-iter '() 8))
|
|
|
|
(my-assert (queens) '(4 2 7 3 6 8 5 1))
|
|
(my-assert (length (set-of (queens))) 92)
|
|
|