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\n")

(display "\nex-4.43\n")

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