From 80adad6179c8a7d32976e3765919ec3c4c0b019b Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Wed, 17 Feb 2021 19:37:53 -0500
Subject: [PATCH] Resolve the issue that caused the amb language parser to fail
 and figure out how to get multiple amb-solutions

---
 ex-4_35-44.scm | 39 ++++++++++++++++++++++++++++++++++++++-
 ex-4_45-xx.scm | 44 ++++++++++++++++++--------------------------
 misc/amb.scm   |  2 --
 3 files changed, 56 insertions(+), 29 deletions(-)

diff --git a/ex-4_35-44.scm b/ex-4_35-44.scm
index b650e6a..f19f6a3 100644
--- a/ex-4_35-44.scm
+++ b/ex-4_35-44.scm
@@ -100,15 +100,37 @@
 (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 am expression and the checks.
+; would have to interleave the amb expression and the checks.
 
 (display "[answered]\n")
 
@@ -216,6 +238,20 @@
 
 (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
@@ -330,4 +366,5 @@
   (queens-iter '() 8))
 
 (my-assert (queens) '(4 2 7 3 6 8 5 1))
+(my-assert (length (set-of (queens))) 92)
 
diff --git a/ex-4_45-xx.scm b/ex-4_45-xx.scm
index 3eae3b4..5047814 100644
--- a/ex-4_45-xx.scm
+++ b/ex-4_45-xx.scm
@@ -1,17 +1,27 @@
 (load "util.scm")
 (load "misc/amb.scm")
 
-(define nouns '(noun cat student professor class))
-(define verbs '(verb eats studies lectures sleeps))
+(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))
 
 (define *unparsed* '())
 
+; By default mit-scheme evaluates the list elements from last to first element.
+; That means with the parse-implementation in the book the later part of a
+; phrase is evaluated first which does not yield any results. To force the
+; correct order we use a let expression and then built the return list from the
+; let variables.
+
+(define (parse-sentence)
+  (let* ((noun-phrase (parse-noun-phrase))
+         (verb-phrase (parse-word verbs)))
+    (list 'sentence noun-phrase verb-phrase)))
+
 (define (parse-noun-phrase)
-  (list 'noun-phrase
-        (parse-word articles)
-        (parse-word nouns)))
+  (let* ((article-phrase (parse-word articles))
+         (noun-phrase (parse-word nouns)))
+  (list 'noun-phrase article-phrase noun-phrase)))
 
 (define (parse-word word-list)
   (require (not (null? *unparsed*)))
@@ -26,31 +36,13 @@
     (require (null? *unparsed*))
     sent))
 
-(define (parse-prepositional-phrase)
-  (list 'prep-phrase
-        (parse-word prepositions)
-        (parse-noun-phrase)))
-
-(define (parse-sentence)
-  (list 'sentence
-         (parse-noun-phrase)
-         (parse-verb-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)))
-
 (display "\nex-4.45 - parse-sentence\n")
 
-;(sentence (noun-phrase (article the) (noun cat)) (verb eats))
+(my-assert (parse '(the cat eats))
+        '(sentence (noun-phrase (article the) (noun cat)) (verb eats)))
 
 ;'(The professor lectures to the student in the class with the cat)
 
-
 (display "\nex-4.46\n")
 
 
diff --git a/misc/amb.scm b/misc/amb.scm
index 8593e75..12051bd 100644
--- a/misc/amb.scm
+++ b/misc/amb.scm
@@ -158,8 +158,6 @@
     (assert (all-different? kitty betty ethel joan mary))
     (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))
 
-(define (require p)
-  (if (not p) (amb)))
 
 ;;; to show cpu time
 (define-syntax cpu-time/sec