SICP/ex-4_35-xx.scm

(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")

; (display "\nex-4.44 - eight-queens\n")