334 lines
12 KiB
Scheme
334 lines
12 KiB
Scheme
|
(load "util.scm")
|
||
|
|
(load "misc/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)))
|
||
|
|
|
||
|
|
; There are five solutions when the adjacent floor constraint for smith and
|
||
|
|
; fletcher is removed.
|
||
|
|
|
||
|
|
(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 am 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 (no-violation new-stmt stmts)
|
||
|
|
(if (null? stmts)
|
||
|
|
#t
|
||
|
|
(let ((stmt (car stmts)))
|
||
|
|
(cond
|
||
|
|
((and (eq? (car new-stmt) (car stmt))
|
||
|
|
(not (eq? (cadr new-stmt) (cadr stmt)))) #f)
|
||
|
|
((and (not (eq? (car new-stmt) (car stmt)))
|
||
|
|
(eq? (cadr new-stmt) (cadr stmt))) #f)
|
||
|
|
(else (no-violation new-stmt (cdr stmts)))))))
|
||
|
|
|
||
|
|
(define (liars-puzzle-1)
|
||
|
|
(let ((stmt-1 (amb '(kitty 2) '(betty 3))))
|
||
|
|
(require (no-violation stmt-1 '()))
|
||
|
|
(let ((stmt-2 (amb '(ethel 1) '(joan 2))))
|
||
|
|
(require (no-violation stmt-2 (list stmt-1)))
|
||
|
|
(let ((stmt-3 (amb '(joan 3) '(ethel 5))))
|
||
|
|
(require (no-violation stmt-3 (list stmt-1 stmt-2)))
|
||
|
|
(let ((stmt-4 (amb '(kitty 2) '(mary 4))))
|
||
|
|
(require (no-violation stmt-4 (list stmt-1 stmt-2 stmt-3)))
|
||
|
|
(let ((stmt-5 (amb '(mary 4) '(betty 1))))
|
||
|
|
(require (no-violation stmt-5 (list stmt-1 stmt-2 stmt-3 stmt-4)))
|
||
|
|
(list stmt-1 stmt-2 stmt-3 stmt-4 stmt-5)))))))
|
||
|
|
|
||
|
|
(define (liars-puzzle statements solution)
|
||
|
|
(if (null? statements)
|
||
|
|
solution
|
||
|
|
(let ((stmt ((car statements))))
|
||
|
|
(require (no-violation stmt solution))
|
||
|
|
(liars-puzzle (cdr statements) (append solution (list stmt))))))
|
||
|
|
|
||
|
|
(define statements (list
|
||
|
|
(lambda () (amb '(kitty 2) '(betty 3)))
|
||
|
|
(lambda () (amb '(ethel 1) '(joan 2)))
|
||
|
|
(lambda () (amb '(joan 3) '(ethel 5)))
|
||
|
|
(lambda () (amb '(kitty 2) '(mary 4)))
|
||
|
|
(lambda () (amb '(mary 4) '(betty 1)))))
|
||
|
|
|
||
|
|
(my-assert (liars-puzzle-1) (liars-puzzle statements '()))
|
||
|
|
|
||
|
|
; Two implementations of the same algorithm. Note that the solution does not
|
||
|
|
; show the position of all students. It only provides a subset of states that
|
||
|
|
; do no result in a violation. We would have to do some further computations on
|
||
|
|
; that result to get the position of each individual student.
|
||
|
|
|
||
|
|
|
||
|
|
(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))
|
||
|
|
|