summaryrefslogtreecommitdiffstats
path: root/ps07_amb/bnewbold_ps07_work.scm
blob: 9419ac8fadf77cbbc6249fb595cad16cb75f4593 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
;;; 6.945 Problem Set #7 Source Code
;;; 03/28/2009
;;; Bryan Newbold <bnewbold@mit.edu>

;(load "load")

;;;------------------------------------------------------------------------
;;; Problem 7.1: Warmup

(define (unique . list)
  (cond ((null? list) #t)
	((memq (car list) (cdr list)) #f)
	(else (apply unique (cdr list)))))
#|
(unique 'a 'b 'c 'd)
; #t
(unique 'a '1 'c '1)
; #f
|#

(define (find-daughters)
  (let ((ann (amb 'moore 'downing 'hall 'hood 'parker))
	(gabrielle (amb 'moore 'downing 'hall 'hood 'parker))
	(lorna (amb 'moore 'downing 'hall 'hood 'parker))
	(rosalind (amb 'moore 'downing 'hall 'hood 'parker))
	(melissa (amb 'moore 'downing 'hall 'hood 'parker))
	(moore 'lorna) 
	(downing 'melissa)
	(hall 'rosalind)
	(hood 'gabrielle)
	(parker 'ann))
    (require (eq? melissa 'hood))
    ;(require (eq? ann 'moore))
    (require (unique melissa ann gabrielle lorna rosalind))
    (require (not (eq? gabrielle 'hood)))
    (require (not (eq? lorna 'moore)))
    (require (not (eq? rosalind 'hall)))
    (require (not (eq? gabrielle 'parker)))
    (let ((yachts (list (list 'moore lorna)
			(list 'downing melissa)
			(list 'hall rosalind)
			(list 'hood gabrielle)
			(list 'parker ann))))
      (require (eq? (cadr (assv gabrielle yachts)) 'parker))
      (display (list (list 'ann ann)
		     (list 'gabrielle gabrielle)
		     (list 'lorna lorna)
		     (list 'rosaline rosalind)
		     (list 'melissa melissa)))
      (newline)
      (amb))))

(with-depth-first-schedule find-daughters)
#|
((ann hall) (gabrielle moore) (lorna parker) (rosaline downing) (melissa hood))
((ann moore) (gabrielle hall) (lorna downing) (rosaline parker) (melissa hood))
;Value: #f
|#

;;;------------------------------------------------------------------------
;;; Problem 7.2

(define (snark-hunt l)
  (call-with-current-continuation
   (lambda (return)
     (letrec ((hunt (lambda (s) 
		      (cond ((null? s) #f)
			    ((list? (car s)) (or (hunt (car s))
						 (hunt (cdr s))))
			    ((eq? (car s) 'snark) (return #t))
			    (else (hunt (cdr s)))))))
       (hunt l)))))

#|
(snark-hunt '(a (1 2 3) v w))
; #f
(snark-hunt '(a (1 2 'snark 3) v w))
; #t
|#