path: root/ps05_pattern_matching/bnewbold_ps05_code.scm

;;; 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

; 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)) 
	     (car (cdr (car table))))
	  (else (lp (cdr table))))))

(define (matcher pattern)
  (let ((match-combinators (match:->combinators pattern)))
    (lambda (datum)
      (set! *pattern-table* '())
      (match-combinators
       (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) 3)
       (eq? (car pattern) '?:pletrec)))

(define (match:pletrec bindings body)
  (define (pletrec-match data dictionary succeed)
    (for-each
     (lambda (x)
       (set! *pattern-table* (cons (list (car x) (cadr x))
				   *pattern-table*)))

     bindings)
    ((match:->combinators body)
     data
     dictionary
     succeed))
  pletrec-match)

(defhandler match:->combinators
  (lambda (x) 
    (match:pletrec (cadr x) (caddr x)))
  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:->combinators pattern)
       data
       dictionary
       succeed))
    ref-match))

(defhandler match:->combinators
  (lambda (x) (match:ref (cadr x)))
  match:ref?)


#| Test Round, GO!

(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 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)))
 '(a b c)
 '()
 (lambda (x y) (display x)))
;Value: #f

; 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 (2 (1 (2 pot-of-gold)))))))
;Value: ()

((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: ()

|#