diff options
Diffstat (limited to 'ps06_rule_systems/matcher.scm')
| -rw-r--r-- | ps06_rule_systems/matcher.scm | 195 |
1 files changed, 195 insertions, 0 deletions
diff --git a/ps06_rule_systems/matcher.scm b/ps06_rule_systems/matcher.scm new file mode 100644 index 0000000..fdc9c7d --- /dev/null +++ b/ps06_rule_systems/matcher.scm @@ -0,0 +1,195 @@ +;;;; Matcher based on match combinators, CPH/GJS style. +;;; Idea is in Hewitt's PhD thesis (1969). + +(declare (usual-integrations)) + +;;; There are match procedures that can be applied to data items. A +;;; match procedure either accepts or rejects the data it is applied +;;; to. Match procedures can be combined to apply to compound data +;;; items. + +;;; A match procedure takes a list containing a data item, a +;;; dictionary, and a success continuation. The dictionary +;;; accumulates the assignments of match variables to values found in +;;; the data. The success continuation takes two arguments: the new +;;; dictionary, and the number of items absorbed from the list by the +;;; match. If a match procedure fails it returns #f. + +;;; Primitive match procedures: + +(define (match:eqv pattern-constant) + (define (eqv-match data dictionary succeed) + (and (pair? data) + (eqv? (car data) pattern-constant) + (succeed dictionary 1))) + eqv-match) + + +;;; Here we have added an optional restriction argument to allow +;;; conditional matches. + +(define (match:element variable #!optional restriction?) + (if (default-object? restriction?) + (set! restriction? (lambda (x) #t))) + (define (element-match data dictionary succeed) + (and (pair? data) + ;; NB: might be many distinct restrictions + (restriction? (car data)) + (let ((vcell (match:lookup variable dictionary))) + (if vcell + (and (equal? (match:value vcell) (car data)) + (succeed dictionary 1)) + (succeed (match:bind variable (car data) dictionary) + 1))))) + element-match) + + +;;; Support for the dictionary. + +(define (match:bind variable data-object dictionary) + (cons (list variable data-object) dictionary)) + +(define (match:lookup variable dictionary) + (assq variable dictionary)) + +(define (match:value vcell) + (cadr vcell)) + +(define (match:segment variable) + (define (segment-match data dictionary succeed) + (and (list? data) + (let ((vcell (match:lookup variable dictionary))) + (if vcell + (let lp ((data data) + (pattern (match:value vcell)) + (n 0)) + (cond ((pair? pattern) + (if (and (pair? data) + (equal? (car data) (car pattern))) + (lp (cdr data) (cdr pattern) (+ n 1)) + #f)) + ((not (null? pattern)) #f) + (else (succeed dictionary n)))) + (let ((n (length data))) + (let lp ((i 0)) + (if (<= i n) + (or (succeed (match:bind variable + (list-head data i) + dictionary) + i) + (lp (+ i 1))) + #f))))))) + segment-match) + +(define (match:list . match-combinators) + (define (list-match data dictionary succeed) + (and (pair? data) + (let lp ((data (car data)) + (matchers match-combinators) + (dictionary dictionary)) + (cond ((pair? matchers) + ((car matchers) data dictionary + (lambda (new-dictionary n) + (if (> n (length data)) + (error "Matcher ate too much." n)) + (lp (list-tail data n) + (cdr matchers) + new-dictionary)))) + ((pair? data) #f) + ((null? data) + (succeed dictionary 1)) + (else #f))))) + list-match) + +;;; Syntax of matching is determined here. + + +(define (match:element? pattern) + (and (pair? pattern) + (eq? (car pattern) '?))) + +(define (match:segment? pattern) + (and (pair? pattern) + (eq? (car pattern) '??))) + +(define (match:variable-name pattern) + (cadr pattern)) + +(define (match:list? pattern) + (and (list? pattern) + (or (null? pattern) + (not (memq (car pattern) '(? ??)))))) + + +;;; These restrictions are for variable elements. + +(define (match:restricted? pattern) + (not (null? (cddr pattern)))) + +(define (match:restriction pattern) + (caddr pattern)) + + +(define match:->combinators + (make-generic-operator 1 match:eqv)) + +(defhandler match:->combinators + (lambda (pattern) (match:element (match:variable-name pattern))) + match:element?) + +(defhandler match:->combinators + (lambda (pattern) (match:segment (match:variable-name pattern))) + match:segment?) + +(defhandler match:->combinators + (lambda (pattern) + (apply match:list (map match:->combinators pattern))) + match:list?) + + +(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)))))) + +#| +((match:->combinators '(a ((? b) 2 3) 1 c)) + '((a (1 2 3) 1 c)) + '() + (lambda (x y) `(succeed ,x ,y))) +;Value: (succeed ((b 1)) 1) + +((match:->combinators '(a ((? b) 2 3) (? b) c)) + '((a (1 2 3) 2 c)) + '() + (lambda (x y) `(succeed ,x ,y))) +;Value: #f + +((match:->combinators '(a ((? b) 2 3) (? b) c)) + '((a (1 2 3) 1 c)) + '() + (lambda (x y) `(succeed ,x ,y))) +;Value: (succeed ((b 1)) 1) + + +((match:->combinators '(a (?? x) (?? y) (?? x) c)) + '((a b b b b b b c)) + '() + (lambda (x y) + (pp `(succeed ,x ,y)) + #f)) +(succeed ((y (b b b b b b)) (x ())) 1) +(succeed ((y (b b b b)) (x (b))) 1) +(succeed ((y (b b)) (x (b b))) 1) +(succeed ((y ()) (x (b b b))) 1) +;Value: #f + +((matcher '(a ((? b) 2 3) (? b) c)) + '(a (1 2 3) 1 c)) +;Value: ((b 1)) +|# |