;; Nada Amin (namin@mit.edu)
;; 6.945 Problem Set 7
;; Due: Wed. 2 Apr. 2008

;(load "../test-manager/load.scm")
(load "load.scm")

;; Problem 7.1

(define (solve-yacht-puzzle knowing-mary-ann-moore?)
  (let ((daughter-barnacle 'melissa)
        (daughter-downing (amb 'mary-ann 'gabrielle 'lorna 'rosalind))
        (daughter-hall (amb 'mary-ann 'gabrielle 'lorna 'rosalind))
        (daughter-moore (if knowing-mary-ann-moore? 'mary-ann (amb 'mary-ann 'gabrielle 'lorna 'rosalind)))
        (daughter-parker (amb 'mary-ann 'lorna 'rosalind))
        (boat-barnacle 'gabrielle)
        (boat-downing 'melissa)
        (boat-hall 'rosalind)
        (boat-moore 'lorna)
        (boat-parker 'mary-ann))
    (let ((father-daughter-boat-list 
           (list (list 'barnacle daughter-barnacle boat-barnacle)
                 (list 'downing daughter-downing boat-downing)
                 (list 'hall daughter-hall boat-hall)
                 (list 'moore daughter-moore boat-moore)
                 (list 'parker daughter-parker boat-parker))))
      (define father car)
      (define daughter cadr)
      (define boat caddr)
      (define daughter&boat cdr)
      ; a father cannot name his boat after his daughter
      (for-each
       (lambda (t)
         (require (distinct? (daughter&boat t))))
       father-daughter-boat-list)
      ; all daughters have distinct names
      (require (distinct? (map daughter father-daughter-boat-list)))
      ; all boats have distinct names
      (require (distinct? (map boat father-daughter-boat-list)))
      ; gabrielle's father owns the yacht that is named after dr. parker's daughter
      (for-each
       (lambda (t)
         (if (eq? (daughter t) 'gabrielle)
             (require (eq? (boat t) daughter-parker))))
       father-daughter-boat-list)
      (for-each
       (lambda (t)
         (if (eq? (daughter t) 'lorna)
             (begin
               (display (list "lorna's father is" (father t)))
               (newline))))
       father-daughter-boat-list)
      (for-each
       (lambda (t)
         (display (list (father t) "is the father of" (daughter t) "and the owner of" (boat t)))
         (newline))
       father-daughter-boat-list)
      (newline)
      (amb))))


(define (solve-yacht-puzzle-knowing) (solve-yacht-puzzle #t))
(define (solve-yacht-puzzle-not-knowing) (solve-yacht-puzzle #f))

#|
(init-amb)
;Value: done

(with-depth-first-schedule solve-yacht-puzzle-knowing)
;(lorna's father is downing)
;(barnacle is the father of melissa and the owner of gabrielle)
;(downing is the father of lorna and the owner of melissa)
;(hall is the father of gabrielle and the owner of rosalind)
;(moore is the father of mary-ann and the owner of lorna)
;(parker is the father of rosalind and the owner of mary-ann)
;Value: #f

(with-depth-first-schedule solve-yacht-puzzle-not-knowing)
;(lorna's father is parker)
;(barnacle is the father of melissa and the owner of gabrielle)
;(downing is the father of rosalind and the owner of melissa)
;(hall is the father of mary-ann and the owner of rosalind)
;(moore is the father of gabrielle and the owner of lorna)
;(parker is the father of lorna and the owner of mary-ann)
;
;(lorna's father is downing)
;(barnacle is the father of melissa and the owner of gabrielle)
;(downing is the father of lorna and the owner of melissa)
;(hall is the father of gabrielle and the owner of rosalind)
;(moore is the father of mary-ann and the owner of lorna)
;(parker is the father of rosalind and the owner of mary-ann)
;
;Value: #f
|#

;; Problem 7.2

;; a

(define (snark-hunt tos)
  (call-with-current-continuation
   (lambda (k)
     (define (rec tos) 
       (if (symbol? tos)
	   (if (eq? 'snark tos)
	       (k #t)
	       #f)
	   (begin
	     (for-each rec tos)
	    #f)))
     (rec tos))))


#|
(snark-hunt '((a b c) 'snark))
; Value: #t
(snark-hunt '((a b c) (snark . "oops") snark))
; Value: #t
(snark-hunt '((a b c) (miao . "oops")))
; error
|#

;; b

(define (snark-hunt/instrumented tos)
  (call-with-current-continuation
   (lambda (k)
     (define (rec tos) 
       (pp `(entering (rec ,tos)))
       (if (symbol? tos)
	   (if (eq? 'snark tos)
	       (k #t)
	       #f)
	   (begin
	     (for-each rec tos)
	    #f))
       (pp `(exiting (rec ,tos)))
       #f)
     (rec tos))))

#|
(snark-hunt/instrumented '((a snark b)))
;(entering (rec ((a snark b))))
;(entering (rec (a snark b)))
;(entering (rec a))
;(exiting (rec a))
;(entering (rec snark))
;Value: #t

(snark-hunt/instrumented '((snark . "oops")))
;(entering (rec ((snark . "oops"))))
;(entering (rec (snark . "oops")))
;(entering (rec snark))
;Value: #t

(snark-hunt/instrumented '(a b))
;(entering (rec (a b)))
;(entering (rec a))
;(exiting (rec a))
;(entering (rec b))
;(exiting (rec b))
;(exiting (rec (a b)))
;Value: #f

|#

;; Problem 7.3

#|

To reach (12 16 20), depth-first has to explore all triples i,j,k>=10
s.t. i<12 or (i=12 and j<16). 

Because we're searching up to 20, to reach (12 16 20), breadth-first
has to explore all the triples that depth-first explores plus many
more, as it explores the triples in a "fair" order.

If we had extended the search beyond 20, breadth-first would not
necessarily be slower than depth-first.

The extra calls to fail are coming from the require clause of
an-integer-between.

a-pythagorean-triple-from is not usable under depth-first because
depth-first fixes i and j and explores all possible k's. Since there
are infinitely many k's, depth-first stalls exploring triples of the
form (10 10 n) for all n>=10.

|#

;; Problem 7.5

;; A.

#|

An unordered (random) AMB might be useful if we're creating a
generator as opposed to a solver. For example, we might want to
generate random grammatical sentences. If we use a deterministic AMB,
the result is rather boring, as we always get the same sentences in
the same order.

|#

(define (generate-sentence)
  (let ((sent (parse-sentence)))
    sent))

(define (some lst)
  (if (null? lst)
      (amb)
      (amb (car lst) (some (cdr lst)))))

(define (parse-word word-list)
  (let ((found-word (some (cdr word-list))))
    (list (car word-list) found-word)))

#|
(init-amb)
(generate-sentence)
;Value: (sentence (s-noun-phrase (article the) (noun student)) (verb studies))
|#

;; B.

(define (order-left-to-right-alternation alternatives)
  alternatives)

(define (order-right-to-left-alternation alternatives)
  (reverse alternatives))

(define (order-random-order-alternation alternatives)
  (define (all-but-one lst k)
    (append (list-head lst k)
	    (list-tail lst (+ k 1))))
  (define (rec n lst)
    (if (= n 0)
	'()
	(let ((i (random n)))
	  (let ((one (list-ref lst i))
		(rest (all-but-one lst i)))
	    (cons one
		  (rec (- n 1)
		       rest))))))
  (rec (length alternatives)
       alternatives))

(define order-alternation ;; Default
  order-left-to-right-alternation)

(define (with-left-to-right-alternation thunk)
  (call-with-current-continuation
   (lambda (k)
     (fluid-let ((order-alternation
		  order-left-to-right-alternation))
       (thunk)))))

(define (with-right-to-left-alternation thunk)
  (call-with-current-continuation
   (lambda (k)
     (fluid-let ((order-alternation
		  order-right-to-left-alternation))
       (thunk)))))

(define (with-random-order-alternation thunk)
  (call-with-current-continuation
   (lambda (k)
     (fluid-let ((order-alternation
		  order-random-order-alternation))
       (thunk)))))

(define (amb-list alternatives)
  (if (null? alternatives)
      (set! *number-of-calls-to-fail*
	    (+ *number-of-calls-to-fail* 1)))
  (call-with-current-continuation
   (lambda (k)
     (add-to-search-schedule
      (order-alternation
       (map (lambda (alternative)
	      (lambda ()
		(within-continuation k alternative)))
	    alternatives)))
     (yield))))


(define (just-the-words lst)
  (define (remove-cats lst)
    (cond ((symbol? lst)
	   lst)
	  ((null? (cdr lst))
	   (just-the-words (car lst)))
	  (else 
	   (map just-the-words (cdr lst)))))
  (define (flatten lst)
    (cond ((symbol? lst)
	   (list lst))
	  ((null? lst)
	   lst)
	  (else
	   (append (flatten (car lst)) (flatten (cdr lst))))))
  (flatten (remove-cats lst)))
#|
(init-amb)
(just-the-words (with-random-order-alternation generate-sentence))
;Value: (the cat eats)
(just-the-words (with-random-order-alternation generate-sentence))
;;Value: (a professor by the cat for the student sleeps)
(just-the-words (with-random-order-alternation generate-sentence))
;Value: (the class studies to the class in a student by the professor in a student in a class in the student)
(just-the-words (with-random-order-alternation generate-sentence))
;Value: (a professor by a student studies)
(just-the-words (with-left-to-right-alternation generate-sentence))
;Value: (the student studies)
(just-the-words (with-right-to-left-alternation generate-sentence))
; out of memory
|#

;; 7.6

(define moby-brain-twister-test
  (lambda ()
    (let ((x) (y) (z))
      (set! x (amb 1 2 3))
      (pp (list x))
      (set! y (amb 'a 'b))
      (pp (list x y))
      (set! z (amb #t #f))
      (pp (list x y z))
      (amb))))

#|
(with-breadth-first-schedule moby-brain-twister-test2)
(with-depth-first-schedule moby-brain-twister-test2)

The explanation is that we run the thunk ((set! x 1) ...) then ((set!
x 2) ...) then ((set! x 3) ...), and so x gets set to three. Then, we
alternate betweent the other options, when we run the inner thunks.

|#