From a50d7eefe9dd50eb0f3876d39e4359b7ed9d5e65 Mon Sep 17 00:00:00 2001 From: bnewbold Date: Mon, 16 Mar 2009 13:44:46 -0400 Subject: as submitted, ps05 --- ps05_pattern_matching/bnewbold_ps05_code.scm | 170 +++++++++++++++++++++------ 1 file changed, 133 insertions(+), 37 deletions(-) (limited to 'ps05_pattern_matching/bnewbold_ps05_code.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 (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: () + +|# -- cgit v1.2.3