SICP/ex-4_35-44.scm

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