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

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

;    Five schoolgirls sat for an examination. Their parents -- so they thought
;    -- showed an undue degree of interest in the result. They therefore agreed
;    that, in writing home about the examination, each girl should make one
;    true statement and one untrue one. The following are the relevant passages
;    from their letters:
;
;        Betty: ``Kitty was second in the examination. I was only third.''
;        Ethel: ``You'll be glad to hear that I was on top. Joan was second.''
;        Joan: ``I was third, and poor old Ethel was bottom.''
;        Kitty: ``I came out second. Mary was only fourth.''
;        Mary: ``I was fourth. Top place was taken by Betty.''
;
;    What in fact was the order in which the five girls were placed?

(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))
(my-assert (length (set-of (queens))) 92)