(load "load.scm")
(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)
(for-each
(lambda (t)
(require (distinct? (daughter&boat t))))
father-daughter-boat-list)
(require (distinct? (map daughter father-daughter-boat-list)))
(require (distinct? (map boat father-daughter-boat-list)))
(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)
(with-depth-first-schedule solve-yacht-puzzle-knowing)
(with-depth-first-schedule solve-yacht-puzzle-not-knowing)
|#
(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))
(snark-hunt '((a b c) (snark . "oops") snark))
(snark-hunt '((a b c) (miao . "oops")))
|#
(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)))
(snark-hunt/instrumented '((snark . "oops")))
(snark-hunt/instrumented '(a b))
|#
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.
|#
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)
|#
(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 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))
(just-the-words (with-random-order-alternation generate-sentence))
(just-the-words (with-random-order-alternation generate-sentence))
(just-the-words (with-random-order-alternation generate-sentence))
(just-the-words (with-left-to-right-alternation generate-sentence))
(just-the-words (with-right-to-left-alternation generate-sentence))
|#
(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.
|#