partial progress

2 files changed, 257 insertions, 0 deletions

diff --git a/ps05_pattern_matching/bnewbold_ps05.txt b/ps05_pattern_matching/bnewbold_ps05.txt
new file mode 100644
index 0000000..64908a3
--- /dev/null
+++ b/ps05_pattern_matching/bnewbold_ps05.txt
@@ -0,0 +1,49 @@
+;;; 6.945 Problem Set #5 Comments
+;;; 03/11/2009
+;;; Bryan Newbold <bnewbold@mit.edu>
+
+Note: Problem numbers were totally off! Jeez! ;)
+
+Problem 5.1: Multiple Matches 
+--------------------------------
+The multiple suceeds are due to the looping let expression ("lp") in 
+match:segment. The first segement match attempt is with n=0, which is why the
+first succeed statement has x null. This is a valid match with y equaling
+(b b b b b b), so the success procedure is called and this match printed, but
+then the failure causes evaluation to drop back to "lp", with n now incremented
+to 1, and the process continutes until n=4, which has no matches at all and
+the #f thunks all the way down to the floor.
+
+Problem 5.2: Multiple Matches 
+--------------------------------
+I allowed match:element declarations to have an optional predicate; the
+procedure corresponding to the predicate symbol is pulled from the nearest repl
+environment. A problem with my implementation is that the predicate is only
+checked for the first reference to the variable; if the predicate is different
+or only specified in one of the later references, the right thing doesn't
+happen.  Eg,
+
+((matcher '(a (? b) (? b integer?) c))
+  '(a t t c))
+; ((b t))
+; should be #f?
+
+Also the predicate has to be a simple symbol existing in the environmnet,
+instead of a lambda expression, maybe I should have used apply?
+
+[see code in bnewbold_ps05_work.scm]
+
+Problem 5.3: Multiple Match Implementation
+--------------------------------
+Ugh, I should really read these problem sets through the whole way first. See
+implementation above, a somewhat ugly method.
+
+Problem 5.4: ?:choice
+--------------------------------
+[see code in bnewbold_ps05_work.scm]
+
+Problem 5.5: ?:pletrec, ?:ref
+--------------------------------
+
+Problem 5.5: restrict
+--------------------------------
diff --git a/ps05_pattern_matching/bnewbold_ps05_code.scm b/ps05_pattern_matching/bnewbold_ps05_code.scm
new file mode 100644
index 0000000..371d7d2
--- /dev/null
+++ b/ps05_pattern_matching/bnewbold_ps05_code.scm
@@ -0,0 +1,208 @@
+
+
+(load "load")
+
+;;; Problem 5.2 and 5.3
+; I redefined match:element to take an optional additional parameter
+
+; ugly style here, haha!
+(define (match:element variable . predicate)
+  (let ((pred (if (eq? (length predicate) 1)
+		  (environment-lookup (nearest-repl/environment) (car predicate))
+		  (lambda (q) #t))))
+    (define (element-match data dictionary succeed)
+      (and (pair? data)
+	   (let ((vcell (match:lookup variable dictionary)))
+	     (if vcell
+		 (and (equal? (match:value vcell) (car data))
+		      (succeed dictionary 1))
+		 (if (pred (car data))
+		     (succeed (match:bind variable (car data) dictionary)
+			      1)
+		     #f)))))
+       element-match))
+
+(define (match:variable-predicate pattern)
+  (caddr pattern))
+
+(defhandler match:->combinators
+  (lambda (pattern) (if (eq? (length pattern) 3)
+			(match:element (match:variable-name pattern)
+				       (match:variable-predicate pattern))
+			(match:element (match:variable-name pattern))))
+  match:element?)
+
+(define (matcher pattern)
+  (let ((match-combinator (match:->combinators pattern)))
+    (lambda (datum)
+      (match-combinator
+       (list datum)
+       '()
+       (lambda (dictionary number-of-items-eaten)
+	 (and (= number-of-items-eaten 1)
+	      dictionary))))))
+
+#| Test it!
+((matcher '(a (?? t) c))
+ '(a 4 4 4 4 4 c))
+;Value: ((t (4 4 4 4 4)))
+
+((matcher '(a (? b integer?) c))
+ '(a 4 c))
+;Value: ((b 4))
+
+((matcher '(a (? b integer?) c))
+ '(a thing c))
+; #f
+
+((matcher '(a (? b integer? 4) (? b integer?) c))
+ '(a 3 3 c))
+; ((b c))
+
+; hmmmm.... i'm just going to call this user error
+((matcher '(a (? b) (? b integer?) c))
+ '(a t t c))
+; ((b t)) 
+
+|#
+
+;;; Problem 5.4
+
+(define (match:choice? pattern)
+  (and (pair? pattern)
+       (eq? (car pattern) '?:choice)))
+
+(define (match:choice match-choices)
+  (define (choice-match data dictionary succeed)
+    (let lp ((m-c match-choices))
+      (if (pair? m-c)
+	  (let ((try ((match:->combinators (car m-c))
+		      data
+		      dictionary
+		      succeed)))
+	    (if try
+		try
+		(lp (cdr m-c))))
+	  #f)))
+  choice-match)
+
+(defhandler match:->combinators
+  (lambda (x) (match:choice (cdr x)))
+  match:choice?) 
+
+#| TEST TIME!
+
+((matcher '(a (?:choice 2 4 6 8) c))
+ '(a 8 c))
+; ()
+
+((matcher '((?? b) 4 (?:choice (? a) (? b) 'other) 8))
+ '(t t t t t t 4 t 8))
+;Value: ((a t) (b (t t t t t t)))
+
+((matcher '((?? b) 4 (?:choice (? b) other) 8))
+ '(t t t t t t 4 other 8))
+;Value: ((b (t t t t t t)))
+
+|#
+
+;;; Problem 5.5
+
+(define *pattern-table* '())
+
+(define (pattern-lookup name)
+  (let lp ((table *pattern-table*))
+    (cond ((null? table) #f)
+	  ((eq? name (caar table)) 
+	   (begin
+	     (display "FOUND!")
+	     (car (cdr (car table)))))
+	  (else (lp (cdr table))))))
+
+(define (matcher pattern)
+  (let ((match-combinator (match:->combinators pattern)))
+    (lambda (datum)
+      (set! *pattern-table* '())
+      (match-combinator
+       (list datum)
+       '()
+       (lambda (dictionary number-of-items-eaten)
+	 (and (= number-of-items-eaten 1)
+	      dictionary))))))
+
+(define (match:pletrec? pattern)
+  (and (pair? pattern)
+       (eq? (length pattern) 2)
+       (eq? (car pattern) '?:pletrec)))
+
+(define (match:pletrec bindings body)
+  (display "made a letrec")
+  (define (pletrec-match data dictionary succeed)
+    (display "trying a letrec")
+    (for-each
+     (set! *pattern-table* (cons (list (car x) (cadr x))
+				 *pattern-table*))
+     bindings)
+    ((match:->combinator body)
+     data
+     dictionary
+     succeed))
+  pletrec-match)
+
+(defhandler match:->combinators
+  (lambda (bindings body) 
+    (display bindings)
+    (display body)
+    (match:pletrec bindings body))
+  match:pletrec?) 
+
+(define (match:ref? pattern)
+  (and (pair? pattern)
+       (eq? (car pattern) '?:ref)))
+
+(define (match:ref name)
+  (let ((pattern (pattern-lookup name)))
+    (define (ref-match data dictionary succeed)
+      ((match:->combinator pattern)
+       data
+       dictionary
+       succeed))
+    ref-match))
+
+(defhandler match:->combinators
+  match:ref
+  match:ref?)
+
+(define (match:list? pattern)
+  (and (list? pattern)
+       (not (memq (car pattern) '(? ?? ?:ref ?:pletrec ?:choice)))))
+
+#| Test Round, GO!
+
+(match:pletrec? '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
+		       (even (?:choice () (2 ?:ref odd))))))
+; #t
+(match:list? '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
+		       (even (?:choice () (2 ?:ref odd))))))
+; #f
+
+((match:->combinators '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
+		       (even (?:choice () (2 ?:ref odd))))
+			   (?:ref odd)))
+ '(a b c)
+ '()
+ (lambda 
+
+((matcher '(?:pletrec ((fancy (1 2 3)))
+			     (?:ref fancy)))
+ '(1 2 3 4 6 7 ))
+
+((matcher '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
+		       (even (?:choice () (2 ?:ref odd))))
+		      (?:ref odd)))
+ '(1 (2 (1 ()))))
+
+*pattern-table*
+
+|#
+