From bfd30bfc1096486f0781e9caea3b15161488f3f6 Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@eta.mit.edu>
Date: Fri, 27 Mar 2009 19:57:08 -0400
Subject: ps07 assignment

---
 ps07_amb/examples.scm | 189 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 189 insertions(+)
 create mode 100644 ps07_amb/examples.scm

(limited to 'ps07_amb/examples.scm')

diff --git a/ps07_amb/examples.scm b/ps07_amb/examples.scm
new file mode 100644
index 0000000..e1162d6
--- /dev/null
+++ b/ps07_amb/examples.scm
@@ -0,0 +1,189 @@
+#|
+|| SICP Section 4.3.2
+|| Logic Puzzles
+||
+|| Baker, Cooper, Fletcher, Miller, and Smith live on
+|| different floors of a building that has only five
+|| floors.  Baker does not live on the top floor.
+|| Cooper does not live on the bottom floor.  Fletcher
+|| does not live on either the top or the bottom
+|| floor.  Miller lives on a higher floor than does
+|| Cooper.  Smith does not live on a floor adjacent to
+|| Fletcher's.  Fletcher does not live on a floor
+|| adjacent to Cooper's.  Where does everyone live?
+||
+||	(From Dinesman, 1968)
+|#
+
+(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)))
+    (require
+     (not (= (abs (- fletcher cooper)) 1)))
+    (list (list 'baker baker)
+          (list 'cooper cooper)
+          (list 'fletcher fletcher)
+          (list 'miller miller)
+          (list 'smith smith))))
+
+(define (distinct? items)
+  (cond ((null? items) #t)
+        ((null? (cdr items)) #t)
+        ((member (car items) (cdr items)) #f)
+        (else (distinct? (cdr items)))))
+
+#|
+(init-amb)
+;Value: done
+
+(with-depth-first-schedule multiple-dwelling)
+;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
+
+(amb)
+;No more alternatives
+|#
+
+;;; From SICP Section 4.3.2
+;;; Parsing natural language
+
+(define (parse input)
+  (amb-set! *unparsed* input)
+  (let ((sent (parse-sentence)))
+    (require (null? *unparsed*))
+    sent))
+
+(define *unparsed* '())
+
+(define (parse-sentence)
+  (let* ((np (parse-noun-phrase))
+	 (verb (parse-verb-phrase)))
+    (list 'sentence np verb)))
+
+(define (parse-noun-phrase)
+  (define (maybe-extend noun-phrase)
+    (amb noun-phrase
+         (maybe-extend
+	  (list 'noun-phrase
+		noun-phrase
+		(parse-prepositional-phrase)))))
+  (maybe-extend (parse-s-noun-phrase)))
+
+(define (parse-verb-phrase)
+  (define (maybe-extend verb-phrase)
+    (amb verb-phrase
+         (maybe-extend
+	  (list 'verb-phrase
+		verb-phrase
+		(parse-prepositional-phrase)))))
+  (maybe-extend (parse-word verbs)))
+
+(define (parse-s-noun-phrase)
+  (let* ((article (parse-word articles))
+	 (noun (parse-word nouns)))
+    (list 's-noun-phrase article noun)))
+
+(define (parse-prepositional-phrase)
+  (let* ((preposition
+	  (parse-word prepositions))
+	 (np (parse-noun-phrase)))
+    (list 'prep-phrase preposition np)))
+
+(define (parse-word word-list)
+  (require (not (null? *unparsed*)))
+  (require (memq (car *unparsed*)
+		 (cdr word-list)))
+  (let ((found-word (car *unparsed*)))
+    (amb-set! *unparsed* (cdr *unparsed*))
+    (list (car word-list) found-word)))
+
+(define nouns
+  '(noun student professor cat class))
+
+(define verbs
+  '(verb studies lectures eats sleeps))
+
+(define articles
+  '(article the a))
+
+(define prepositions
+  '(prep for to in by with))
+
+#|
+(init-amb)
+;Value: done
+
+(pp
+ (parse
+  '(the student with the cat sleeps in the class)))
+
+(sentence
+ (noun-phrase
+  (s-noun-phrase (article the) (noun student))
+  (prep-phrase (prep with)
+	       (s-noun-phrase (article the)
+			      (noun cat))))
+ (verb-phrase
+  (verb sleeps)
+  (prep-phrase (prep in)
+	       (s-noun-phrase (article the)
+			      (noun class)))))
+;Unspecified return value
+
+(amb)
+;No more alternatives
+|#
+
+#|
+(init-amb)
+;Value: done
+
+(pp
+ (parse
+  '(the professor lectures
+	to the student with the cat)))
+
+(sentence
+ (s-noun-phrase (article the) (noun professor))
+ (verb-phrase
+  (verb-phrase
+   (verb lectures)
+   (prep-phrase (prep to)
+		(s-noun-phrase (article the)
+			       (noun student))))
+  (prep-phrase (prep with)
+	       (s-noun-phrase (article the)
+			      (noun cat)))))
+;Unspecified return value
+
+(amb)
+
+(sentence
+ (s-noun-phrase (article the) (noun professor))
+ (verb-phrase
+  (verb lectures)
+  (prep-phrase
+   (prep to)
+   (noun-phrase
+    (s-noun-phrase (article the)
+		   (noun student))
+    (prep-phrase (prep with)
+		 (s-noun-phrase (article the)
+				(noun cat)))))))
+;Unspecified return value
+
+(amb)
+;No more alternatives
+|#
-- 
cgit v1.2.3