as submitted, ps05

2 files changed, 146 insertions, 37 deletions

diff --git a/ps05_pattern_matching/bnewbold_ps05.txt b/ps05_pattern_matching/bnewbold_ps05.txt
index 64908a3..6ce38a1 100644
--- a/ps05_pattern_matching/bnewbold_ps05.txt
+++ b/ps05_pattern_matching/bnewbold_ps05.txt
@@ -44,6 +44,19 @@ Problem 5.4: ?:choice
 
 Problem 5.5: ?:pletrec, ?:ref
 --------------------------------
+I couldn't get match:list? to override for some reason, so '() isn't handled
+with an eqv combinator like it should be.
+
+I used a global dictionary *pattern-table* which gets added to by each pletrec
+statement and reset to '() by every matcher expression.
+
+[see code in bnewbold_ps05_work.scm]
 
 Problem 5.5: restrict
 --------------------------------
+Somewhere along the line i've made some horrible mistake handling lists because
+the null list isn't handled right. But I can't figure out what's wrong, the
+next step for me would be to rewrite everything; my namespace gets polluted
+with old versions of handlers pretty fast.
+
+[see code in bnewbold_ps05_work.scm]
diff --git a/ps05_pattern_matching/bnewbold_ps05_code.scm b/ps05_pattern_matching/bnewbold_ps05_code.scm
index 371d7d2..3149508 100644
--- a/ps05_pattern_matching/bnewbold_ps05_code.scm
+++ b/ps05_pattern_matching/bnewbold_ps05_code.scm
@@ -1,7 +1,21 @@
-
+;;; 6.945 Problem Set #5 Source Code
+;;; 03/11/2009
+;;; Bryan Newbold <bnewbold@mit.edu>
 
 (load "load")
 
+; Gotta redefine these at the get go to deal with all the extensions
+(define (match:list? pattern)
+  (and (list? pattern)
+       (if (not (null? pattern))
+       (not (memq (car pattern) '(? ?? ?:ref ?:pletrec ?:choice ?:restrict)))
+       #f)))
+
+(defhandler match:->combinators
+  (lambda (pattern)
+    (apply match:list (map match:->combinators pattern)))
+  match:list?)
+
 ;;; Problem 5.2 and 5.3
 ; I redefined match:element to take an optional additional parameter
 
@@ -114,16 +128,14 @@
   (let lp ((table *pattern-table*))
     (cond ((null? table) #f)
 	  ((eq? name (caar table)) 
-	   (begin
-	     (display "FOUND!")
-	     (car (cdr (car table)))))
+	     (car (cdr (car table))))
 	  (else (lp (cdr table))))))
 
 (define (matcher pattern)
-  (let ((match-combinator (match:->combinators pattern)))
+  (let ((match-combinators (match:->combinators pattern)))
     (lambda (datum)
       (set! *pattern-table* '())
-      (match-combinator
+      (match-combinators
        (list datum)
        '()
        (lambda (dictionary number-of-items-eaten)
@@ -132,29 +144,27 @@
 
 (define (match:pletrec? pattern)
   (and (pair? pattern)
-       (eq? (length pattern) 2)
+       (eq? (length pattern) 3)
        (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*))
+     (lambda (x)
+       (set! *pattern-table* (cons (list (car x) (cadr x))
+				   *pattern-table*)))
+
      bindings)
-    ((match:->combinator body)
+    ((match:->combinators body)
      data
      dictionary
      succeed))
   pletrec-match)
 
 (defhandler match:->combinators
-  (lambda (bindings body) 
-    (display bindings)
-    (display body)
-    (match:pletrec bindings body))
-  match:pletrec?) 
+  (lambda (x) 
+    (match:pletrec (cadr x) (caddr x)))
+  match:pletrec?)
 
 (define (match:ref? pattern)
   (and (pair? pattern)
@@ -163,46 +173,132 @@
 (define (match:ref name)
   (let ((pattern (pattern-lookup name)))
     (define (ref-match data dictionary succeed)
-      ((match:->combinator pattern)
+      ((match:->combinators pattern)
        data
        dictionary
        succeed))
     ref-match))
 
 (defhandler match:->combinators
-  match:ref
+  (lambda (x) (match:ref (cadr x)))
   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))))))
+(match:pletrec? '(?:pletrec ((odd (?:choice pot-of-gold (1 ?:ref even)))
+			     (even (?:choice pot-of-gold (2 ?:ref odd))))
+			    (?:ref odd)))
 ; #t
-(match:list? '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
-		       (even (?:choice () (2 ?:ref odd))))))
+(match:list? '(?:pletrec ((odd (?:choice pot-of-gold (1 ?:ref even)))
+			     (even (?:choice pot-of-gold (2 ?:ref odd))))
+			    (?:ref odd)))
 ; #f
 
+((match:->combinators '(?:pletrec ((thing (1 2 3)))
+				  (?:ref thing)))
+ '((1 2 3))
+ '()
+ (lambda (x y) (display x)))
+;()
+;Unspecified return value
+
+((match:->combinators '(?:pletrec ((thing (?:choice a b c)))
+				  (?:ref thing)))
+ '(c)
+ '()
+ (lambda (x y) (display x)))
+;()
+;Unspecified return value
+
+((match:->combinators '(?:pletrec ((a 4)) 
+				  (?:ref a)))
+ '(4)
+ '()
+ (lambda (x y) (display x)))
+;()
+;Unspecified return value
+
 ((match:->combinators '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
-		       (even (?:choice () (2 ?:ref odd))))
-			   (?:ref odd)))
+				   (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 ))
+ (lambda (x y) (display x)))
+;Value: #f
 
-((matcher '(?:pletrec ((odd (?:choice () (1 ?:ref even)))
-		       (even (?:choice () (2 ?:ref odd))))
+; I couldn't get match:list? to override for some reason, so '() isn't
+; handled with an eqv combinator like it should be
+((matcher '(?:pletrec ((odd (?:choice pot-of-gold (1 (?:ref even))))
+		       (even (?:choice pot-of-gold (2 (?:ref odd)))))
 		      (?:ref odd)))
- '(1 (2 (1 ()))))
+ '(1 (2 (1 (2 (1 (2 pot-of-gold)))))))
+;Value: ()
 
-*pattern-table*
+((matcher '(?:pletrec ((odd (?:choice pot-of-gold (1 (?:ref even))))
+		       (even (?:choice pot-of-gold (2 (?:ref odd)))))
+		      (?:ref odd)))
+ '(1 (2 (1 (2 (1 (2)))))))
+;Value: #f
 
 |#
 
+;;; Problem 5.5
+
+(define (match:restrict? pattern)
+  (and (pair? pattern)
+       (eq? (car pattern) '?:restrict)))
+
+(define (match:restrict predicate)
+  (define (restrict-match data dictionary succeed)
+    (if ((environment-lookup (nearest-repl/environment) predicate) 
+	 (if (pair? data) (car data) data))
+	(succeed dictionary 1)
+	#f))
+  restrict-match)
+
+(defhandler match:->combinators
+  (lambda (x) (match:restrict (cadr x)))
+  match:restrict?)
+
+#| And now for something completely predictable
+
+((matcher '(a b (?:restrict integer?)))
+ '(a b 2))
+;Value: ()
+
+((matcher '(5))
+ '(5))
+
+((matcher '(g (?:restrict integer?)))
+ '(g 4))
+;Value: ()
+
+(match:list? '(4))
+
+(define btos-checker 
+  (matcher '(?:pletrec ((btos
+			 (?:choice null
+				   (?:restrict symbol?)
+				   ((?:ref btos) (?:ref btos)))))
+		       (binary tree of symbols: (?:ref btos)))))
+
+(btos-checker '(binary tree of symbols: null ))
+;Value: ()
+(btos-checker '(binary tree of symbols: (a b) ))
+;Value: ()
+(btos-checker '(binary tree of symbols: ((a b) (c null)) ))
+;Value: ()
+(btos-checker '(binary tree of symbols: (a null) ))
+;Value: ()
+(btos-checker '(binary tree of symbols: (a) ))
+;ERROR
+(btos-checker '(binary tree of symbols: (2 a) ))
+;Value: #f
+(btos-checker '(binary tree of symbols: (a b) ))
+
+((matcher '(a (?:choice null (?:restrict symbol?))))
+ '(a null))
+;Value: ()
+
+|#