summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ps05_pattern_matching/bnewbold_ps05.txt13
-rw-r--r--ps05_pattern_matching/bnewbold_ps05_code.scm170
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: ()
+
+|#