diff options
Diffstat (limited to 'ps05_pattern_matching/bnewbold_ps05_code.scm')
-rw-r--r-- | ps05_pattern_matching/bnewbold_ps05_code.scm | 208 |
1 files changed, 208 insertions, 0 deletions
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* + +|# + |