From 1bb045d3580d2b21794d109461fbe064ae38f3b8 Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@eta.mit.edu>
Date: Sun, 8 Mar 2009 23:04:16 -0400
Subject: as submitted

---
 ps04_combinators_amb/analyze-amb.scm            |  17 +-
 ps04_combinators_amb/bnewbold_ps04.txt          | 174 +++++++++++++++++-
 ps04_combinators_amb/bnewbold_ps04_work.scm     | 231 ++++++++++++++++++++++++
 ps04_combinators_amb/load-amb.scm               |   7 +-
 ps04_combinators_amb/load-analyze.scm           |   4 +-
 ps04_combinators_amb/multiple-dwelling_edit.scm |  32 ++++
 ps04_combinators_amb/repl-amb.scm               |   6 +
 7 files changed, 462 insertions(+), 9 deletions(-)
 create mode 100644 ps04_combinators_amb/multiple-dwelling_edit.scm

diff --git a/ps04_combinators_amb/analyze-amb.scm b/ps04_combinators_amb/analyze-amb.scm
index 5d5ad56..cc98c12 100644
--- a/ps04_combinators_amb/analyze-amb.scm
+++ b/ps04_combinators_amb/analyze-amb.scm
@@ -2,6 +2,13 @@
 ;;;   Execution procedures take environment 
 ;;;   and two continuations: SUCCEED and FAIL
 
+(define *amb-count* 0)
+(define (show-amb-count)
+  (display "Number of alts considered: ")
+  (display *amb-count*)
+  (newline)
+  (set! *amb-count* 0))
+
 (define (ambeval exp env succeed fail)
   ((analyze exp) env succeed fail))
 
@@ -187,10 +194,12 @@
       (let loop ((alts aprocs))
 	(if (null? alts)
 	    (fail)
-	    ((car alts) env
-	                succeed
-			(lambda ()
-			  (loop (cdr alts)))))))))
+ 	    (begin
+	      (set! *amb-count* (+ 1 *amb-count*))
+	      ((car alts) env
+			  succeed
+			  (lambda ()
+			    (loop (cdr alts))))))))))
 
 (defhandler analyze analyze-amb amb?)
 
diff --git a/ps04_combinators_amb/bnewbold_ps04.txt b/ps04_combinators_amb/bnewbold_ps04.txt
index 0203e57..58d49b1 100644
--- a/ps04_combinators_amb/bnewbold_ps04.txt
+++ b/ps04_combinators_amb/bnewbold_ps04.txt
@@ -4,15 +4,187 @@
 
 Problem 4.1: Warmup
 ---------------------
+The way I interpreted this question, all the parameters are passed in one list,
+as opposed to a finite list of specified parameters plus an arbitrary length
+list containing all the "left over" parameters.
+
 
 Problem 4.2: Infix Notation
 -----------------------------
+I attacked this problem with the natural language pattern matching technique
+described in SICP. First I wrote a crude register-machine-style parser which
+turns the infix string into a list which is easier to parse and match over.
+Each element in the list is tagged with it's type (eg, number, variable,
+open-parenthesis, etc).  Then I identified the following types of expressions:
+
+    number: [number] 
+    variable: [variable]
+    binary: [expression] [oper] [expression]
+    chunk: [open-paren] [expression] [close-paren]
+    function: [variable] [open-paren] [expression] [close-paren]
+
+There's potential for an infinite loop when trying to match an expression
+as a binary expression starting with an expression starting with a binary
+expression [etc etc], so I defined "simple-expressions" as any of the above
+types minus binary, and redefined binary as:
+
+    binary: [simple-expression] [oper] [expression]
+
+I'm pretty sure this keeps the system general.
+
+Then I do amb-style pattern matching with requires, and finally "lispify"
+the resulting parse tree into an s-expression and evaluate it.
+
+To do the final evaluation of the parsed code I added this line to 
+load-amb.scm:
+
+(define (eval-in-amb exp)
+  (eval exp generic-evaluation-environment))
+
+This doesn't really work the way I want, but the-global-environment apparently
+isn't a real environment (?!?!) and I can't get the usual
+nearest-repl/environment. Variables defined in the
+generic-evaluation-environment are substituted properly into the final
+evaluation. Eg:
+
+    ;;; Amb-Eval input:
+    (define y 10)
+
+    ;;; Starting a new problem
+    ;;; Amb-Eval value:
+    Number of alts considered: 0
+    y
+
+    ;;; Amb-Eval input:
+    (infix "y")
+
+    ;;; Starting a new problem
+    ;Unbound variable: y
+
+But then, 
+
+    1 ]=> (define x 5)
+    ;Value: x
+
+    1 ]=> (go)
+
+    ;;; Amb-Eval input:
+    (infix "x")
 
+    ;;; Starting a new problem 
+    ;;; Amb-Eval value:
+    Number of alts considered: 4
+    5
 
-Problem 4.3: Programming with AMB
+There are one or two other missing pieces: all operators are binary without the
+appropriate precedence, decimal numbers aren't recognized, variables have to
+be lowercase, negative numbers don't work (use, eg, 0-45 instead), and operators
+are just any string of characters made up of "*+/-^" passed straight through,
+so exponentiation doesn't work.
+
+[see code in bnewbold_ps04_work.scm]
+
+Problem 4.38
+-----------------------------------
+This was only a one line change in the code, remove the line:
+
+    (require (not (= (abs (- fletcher smith)) 1)))
+
+By trying it in the evaluator, I found 5 possible solutions:
+
+    ((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
+    ((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
+    ((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
+    ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
+    ((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
+
+Problem 4.39
+-----------------------------------
+The order matters in that it can change the order that solutions are found, 
+and definately changes the speed with which they are found. The actual set of
+solutions does not change; all solutions will still meet the requirements.
+
+The given order of the requirements actually does a reasonable job optimizing
+for the speed of the search. Putting the most restrictive requirements first
+will help reduce the number of checks and backtraces performed, so I would put
+the (require (> miller cooper)) first.
+
+Problem 4.40
 -----------------------------------
+There are 5^5=3125 assignments before the distinct requirement and 5!=120 after.
+Here's my fast version:
 
+(define (multiple-dwelling-fast)
+  (let ((fletcher (amb 1 2 3 4 5)))
+    (require (not (= fletcher 5)))
+    (require (not (= fletcher 1)))
+    (let ((cooper (amb 1 2 3 4 5)))
+      (require (not (= cooper 1)))
+      (require (not (= (abs (- fletcher cooper)) 1)))
+      (let ((miller (amb 1 2 3 4 5)))
+        (require (> miller cooper))
+        (let ((smith (amb 1 2 3 4 5)))
+          (require (not (= (abs (- smith fletcher)) 1)))
+          (let ((baker (amb 1 2 3 4 5)))
+            (require (not (= baker 5)))
+            (require
+             (distinct (list baker cooper fletcher miller smith)))
+            (list (list 'baker baker)
+                  (list 'cooper cooper)
+                  (list 'fletcher fletcher)
+                  (list 'miller miller)
+                  (list 'smith smith))))))))
+
+Of coure a big help would be simply removing the impossible floors from the amb
+statements for individual people; eg because Cooper can't live on the first 
+floor, just remove 1 from that amb statement. 
 
 Problem 4.4: Profiling AMB
 ----------------------------
+My version ("multiple-dwelling-fast") makes 210 alternative attempts, while the
+original makes 1840 attempts.
+
+The changes I made were to analyze-amb.scm:
+
+(define *amb-count* 0)
+(define (show-amb-count)
+  (display "Number of alts considered: ")
+  (display *amb-count*)
+  (newline)
+  (set! *amb-count* 0))
+
+and repl-amb.scm:
+
+(define (driver-loop)
+  (define (internal-loop try-again)
+    (let ((input
+           (prompt-for-command-expression input-prompt)))
+      (if (eq? input 'try-again)
+          (try-again)
+          (begin
+            (newline)
+            (display ";;; Starting a new problem ")
+            (evaluator
+             input
+             (lambda (val next-alternative)
+               (display output-prompt)
+           (show-amb-count)  ;;;;;;;;;  THIS LINE ADDED
+               (pp val)
+               (internal-loop next-alternative))
+             (lambda ()
+               (display ";;; There are no more values of ")
+               (pp input)
+               (driver-loop)))))))
+  (internal-loop
+   (lambda ()
+     (display ";;; There is no current problem")
+     (driver-loop))))
+
+#| Example:
+eval> (multiple-dwelling)
+;;; Starting a new problem
+;;; Amb-Eval value:
+Number of alts considered: 1840
+((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
 
+|#
diff --git a/ps04_combinators_amb/bnewbold_ps04_work.scm b/ps04_combinators_amb/bnewbold_ps04_work.scm
index e69de29..5bcaf99 100644
--- a/ps04_combinators_amb/bnewbold_ps04_work.scm
+++ b/ps04_combinators_amb/bnewbold_ps04_work.scm
@@ -0,0 +1,231 @@
+;;; 6.945 Problem Set #4 Source Code
+;;; 03/04/2009
+;;; Bryan Newbold <bnewbold@mit.edu>
+
+; Note: this file is usually loaded from the load-*.scm files into 
+; the-generic-evaluation-environment
+
+;---------------------------
+; Problem 4.1
+
+#| ; This conflicts with the infix code below, so leave it commented in
+   ; when testing that code.
+
+(defhandler execute-application
+  (lambda (proc args)
+    ((procedure-body proc)
+     (if (list? (procedure-parameters proc))
+	 (extend-environment 
+	  (procedure-parameters proc)
+	  args
+	  (procedure-environment proc))
+	 (extend-environment 
+	  (list (procedure-parameters proc))
+	  (list args)
+	  (procedure-environment proc)))))
+     compound-procedure?)
+|#
+#| Testing:
+
+eval> (define (ss . x) (map square x))
+ok
+eval> (ss 1 2 3)
+(1 4 9)
+
+; and the regular syntax still works:
+
+eval> (define (s2 x y) (list (square x) (square y)))
+ok
+eval> (s2 1 2 3 4 5)
+;Too many arguments supplied (x y) (1 2 3 4 5)
+eval> (s2 1 2)
+(1 4)
+|#
+
+
+;---------------------------
+; Problem 4.2
+
+; first we gotta listify the infix string or life will suck
+(define (infix-operator? x)
+  (member x (string->list "+-*^/")))
+(define (infix-open-paren? x)
+  (member x (string->list "(")))
+(define (infix-close-paren? x)
+  (member x (string->list ")")))
+(define (infix-var? x)
+  (member x (string->list "abcdefghijklmnopqrstuvwxyz")))
+(define (infix-number? x)
+  (member x (string->list "0123456789")))
+(define (infix-same-type? a b)
+  (cond ((infix-operator? a) (infix-operator? b))
+	((infix-open-paren? a) (infix-open-paren? b))
+	((infix-close-paren? a) (infix-close-paren? b))
+	((infix-number? a) (infix-number? b))
+	((infix-var? a) (infix-var? b))
+	(else (error "Not a valid infix char type: " a))))
+(define (infix-tag-type x)
+  (let ((tag (cond ((infix-operator? (car x)) 'oper)
+		   ((infix-open-paren? (car x)) 'open-paren)
+		   ((infix-close-paren? (car x)) 'close-paren)
+		   ((infix-var? (car x)) 'variable)
+		   ((infix-number? (car x)) 'number)
+		   (else (error "Something wrong, not a type: " x)))))
+    (list tag (list->string (reverse x)))))
+
+(define (listify in)
+  (define out '())
+  (define prog '())
+  (define (work chunk)
+    (cond ((null? chunk)
+	   (cons (infix-tag-type prog) out))
+	  ((equal? (car chunk) #\space)
+	   (work (cdr chunk)))
+	  ((null? prog) 
+	   (begin
+	     (set! prog (cons (car chunk) prog))
+	     (work (cdr chunk))))
+	  ((and (infix-same-type? (car prog) (car chunk))
+		(not (or (infix-open-paren? (car prog))
+			 (infix-close-paren? (car prog)))))
+	   (begin 
+	     (set! prog (cons (car chunk) prog))
+	     (work (cdr chunk))))
+	  (else 
+	   (begin
+	     (set! out (cons (infix-tag-type prog) out))
+	     (set! prog (list (car chunk)))
+	     (work (cdr chunk))))))
+  (reverse (work (string->list in))))
+
+#| Test:
+(listify "4+34^4-(a*a+b^2)")
+;Value: ((number "4") (oper "+") (number "34") (oper "^") (number "4") (oper "-") (open-paren "(") (var "a") (oper "*") (var "a") (oper "+") (var "b") (oper "^") (number "2") (close-paren ")"))
+
+(listify "4+34^4 - ( a*a + b^2)")
+;Value: ((number "4") (oper "+") (number "34") (oper "^") (number "4") (oper "-") (open-paren "(") (var "a") (oper "*") (var "a") (oper "+") (var "b") (oper "^") (number "2") (close-paren ")"))
+|#
+
+; alright, now we can do fun NLP mojo
+
+
+#| These definitions should be pasted into an amb-evaluator:
+
+(define (require p)
+  (if (not p) (amb)))
+
+(define *unparsed* '())
+
+(define (parse-type t)
+  (require (not (null? *unparsed*)))
+  (require (equal? (caar *unparsed*) t))
+  (let ((found-type (car *unparsed*)))
+    (set! *unparsed* (cdr *unparsed*))
+    found-type))
+
+(define (parse-binary)
+  (list 'binary
+	(parse-simple-expression)
+	(parse-type 'oper)
+	(parse-expression)))
+
+(define (parse-chunk)
+  (list 'chunk
+	(parse-type 'open-paren)
+	(parse-expression)
+	(parse-type 'close-paren)))
+
+(define (parse-function)
+  (list 'function
+	(parse-type 'variable)
+	(parse-chunk)))
+
+(define (parse-simple-expression)
+  (amb (parse-type 'number)
+       (parse-type 'variable)
+       (parse-chunk)
+       (parse-function)))
+
+(define (parse-expression)
+  (amb (parse-type 'number)
+       (parse-type 'variable)
+       (parse-binary)
+       (parse-chunk)
+       (parse-function)))
+
+(define (parse-infix in)
+  (set! *unparsed* (listify in))
+  (let ((sent (parse-expression)))
+    (require (null? *unparsed*))
+    sent))
+
+#| Test:
+;;; Amb-Eval input:
+(parse-infix "sqrt(5+square(4*4))")
+
+;;; Starting a new problem 
+;;; Amb-Eval value:
+Number of alts considered: 99
+(function
+ (variable "sqrt")
+ (chunk
+  (open-paren "(")
+  (binary
+   (number "5")
+   (oper "+")
+   (function
+    (variable "square")
+    (chunk (open-paren "(")
+           (binary (number "4") (oper "*") (number "4"))
+           (close-paren ")"))))
+  (close-paren ")")))
+
+;;; Amb-Eval input:
+(parse-infix "1+2+4+5")
+
+;;; Starting a new problem 
+;;; Amb-Eval value:
+Number of alts considered: 13
+(binary
+ (number "1")
+ (oper "+")
+ (binary (number "2")
+         (oper "+")
+         (binary (number "4") (oper "+") (number "5"))))
+
+|#
+
+(define (lispify parsed)
+  (cond ((eq? (car parsed) 'function)
+	 (list (lispify (car (cdr parsed)))
+	       (lispify (car (cdr (cdr parsed))))))
+	((eq? (car parsed) 'variable)
+	 (string->symbol (car (cdr parsed))))
+	((eq? (car parsed) 'number)
+	 (string->number (car (cdr parsed))))
+	((eq? (car parsed) 'binary)
+	 (list (lispify (car (cdr (cdr parsed))))
+	       (lispify (car (cdr parsed)))
+	       (lispify (car (cdr (cdr (cdr parsed)))))))
+	((eq? (car parsed) 'chunk)
+	 (lispify (car (cdr (cdr parsed)))))
+	((eq? (car parsed) 'oper)
+	 (string->symbol (car (cdr parsed))))
+	(else (error "Unhandled type: " (car parsed)))))
+
+; note, this requres eval-in-amb to be defined in the top level
+(define (infix in)
+  (eval-in-amb (lispify (parse-infix in))))
+
+#|
+; x needs to be defined in the top level; here it's 5
+
+;;; Amb-Eval input:
+(infix "sqrt(4+3/x*square(56 - 83))")
+
+;;; Starting a new problem 
+;;; Amb-Eval value:
+Number of alts considered: 146
+2.0002057507335316
+
+|#
diff --git a/ps04_combinators_amb/load-amb.scm b/ps04_combinators_amb/load-amb.scm
index 6f3d1a8..a2ec775 100644
--- a/ps04_combinators_amb/load-amb.scm
+++ b/ps04_combinators_amb/load-amb.scm
@@ -7,8 +7,11 @@
 (define generic-evaluation-environment
   (extend-top-level-environment user-initial-environment))
 
+(define (eval-in-amb exp)
+  (eval exp generic-evaluation-environment))
+
 (load "analyze-amb" generic-evaluation-environment)
+(load "bnewbold_ps04_work" generic-evaluation-environment)
 (load "repl-amb" generic-evaluation-environment)
 
-
-(ge generic-evaluation-environment)
\ No newline at end of file
+(ge generic-evaluation-environment)
diff --git a/ps04_combinators_amb/load-analyze.scm b/ps04_combinators_amb/load-analyze.scm
index 02e447e..1d274ae 100644
--- a/ps04_combinators_amb/load-analyze.scm
+++ b/ps04_combinators_amb/load-analyze.scm
@@ -3,11 +3,11 @@
 (load "syntax" user-initial-environment)
 (load "rtdata" user-initial-environment)
 
-
 (define generic-evaluation-environment
   (extend-top-level-environment user-initial-environment))
 
 (load "analyze" generic-evaluation-environment)
+(load "bnewbold_ps04_work" generic-evaluation-environment)
 (load "repl" generic-evaluation-environment)
 
-(ge generic-evaluation-environment)
\ No newline at end of file
+(ge generic-evaluation-environment)
diff --git a/ps04_combinators_amb/multiple-dwelling_edit.scm b/ps04_combinators_amb/multiple-dwelling_edit.scm
new file mode 100644
index 0000000..e6ee53d
--- /dev/null
+++ b/ps04_combinators_amb/multiple-dwelling_edit.scm
@@ -0,0 +1,32 @@
+
+(define (require p)
+  (if (not p) (amb)))
+
+(define (distinct l)
+  (cond ((null? l) true)
+	((null? (cdr l)) true)
+	((member (car l) (cdr l)) false)
+	(else (distinct (cdr l)))))
+
+
+(define (multiple-dwelling-fast)
+  (let ((fletcher (amb 1 2 3 4 5)))
+    (require (not (= fletcher 5)))
+    (require (not (= fletcher 1)))
+    (let ((cooper (amb 1 2 3 4 5)))
+      (require (not (= cooper 1)))
+      (require (not (= (abs (- fletcher cooper)) 1)))
+      (let ((miller (amb 1 2 3 4 5)))
+        (require (> miller cooper))
+	(let ((smith (amb 1 2 3 4 5)))
+	  (require (not (= (abs (- smith fletcher)) 1)))
+	  (let ((baker (amb 1 2 3 4 5)))
+	    (require (not (= baker 5)))
+	    (require
+	     (distinct (list baker cooper fletcher miller smith)))
+	    (list (list 'baker baker)
+		  (list 'cooper cooper)
+		  (list 'fletcher fletcher)
+		  (list 'miller miller)
+		  (list 'smith smith))))))))
+
diff --git a/ps04_combinators_amb/repl-amb.scm b/ps04_combinators_amb/repl-amb.scm
index c7b6ccb..90311b0 100644
--- a/ps04_combinators_amb/repl-amb.scm
+++ b/ps04_combinators_amb/repl-amb.scm
@@ -66,6 +66,7 @@
              input
              (lambda (val next-alternative)
                (display output-prompt)
+	       (show-amb-count)
                (pp val)
                (internal-loop next-alternative))
              (lambda ()
@@ -78,3 +79,8 @@
      (driver-loop))))
 
 (define go driver-loop)
+
+
+
+
+
-- 
cgit v1.2.3