;; Nada Amin (namin@mit.edu)
;; 6.945 Problem Set 3
;; Due: Wed. 27 Feb. 2008

(load "../test-manager/load.scm")
(load "matcher.scm")

;; Problem 3.1

#|

In match:segment, the line

(or (succeed (match:bind variable (list-head data i) dictionary) i)
    (lp (+ i 1)))

ensures that we move on to the next possibility, via (lp (+ i 1)), if
succeed fails. Thus, by returning #f from the succeed procedure (while
first printing the successful match), the first clause of the or will
always fail ensuring that we try the alternative possibility
regardless of whether the first succeeded in practice. This way, we
end up printing all successful matches.

|#

;; Problem 3.2

#|

I chose to implement pattern variables with restrictions by making an
entirely new matcher procedure, match:element-restricted, which is
built on top of match:element.

|#

(define (match:element-restricted variable predicate)
  (let ((matcher (match:element variable)))
    (define (element-restricted-match data dictionary succeed)
      (matcher data dictionary 
               (lambda (dictionary number-of-items-eaten)
                 (let ((value (match:value 
                               (match:lookup variable dictionary))))
                   (and (predicate value)
                        (succeed dictionary number-of-items-eaten))))))
    element-restricted-match))

(in-test-group
 match:element-restricted
 (define-test ()
   (assert-equal
    ((match:element 'a) '(1) '() list)
    '(((a 1)) 1))
   (assert-equal
    ((match:element-restricted 'a number?) '(1) '() list)
    '(((a 1)) 1)))
 (define-test ()
   (assert-equal
    ((match:element 'a) '(foo) '() list)
    '(((a foo)) 1))
   (assert-equal
    ((match:element-restricted 'a number?) '(foo) '() list)
    #f))
 (define-test ()
   (assert-equal
    ((match:element-restricted 'a number?) '() '() list)
    #f))
 )

;; Problem 3.3

#|

I choose to solve the problem of evaluating predicates by using a
quasiquote interface. I feel this choice gives more flexibility to the
user, who can use the environment in which the pattern matching occurs
as opposed to the global environment in defining his predicates.

|#

(define (match:element-restricted? pattern)
  (and (match:element? pattern)
       (not (null? (cddr pattern)))))

(define (match:predicate pattern)
  (caddr pattern))

(define (match:->combinators pattern)
  (define (compile pattern)
    (cond ((match:element-restricted? pattern)
           (match:element-restricted (match:variable-name pattern) (match:predicate pattern)))
          ((match:element? pattern)
           (match:element (match:variable-name pattern)))
          ((match:segment? pattern)
           (match:segment (match:variable-name pattern)))
          ((list? pattern)
           (apply match:list (map compile pattern)))
          (else (match:eqv pattern))))
  (compile pattern))

(in-test-group
 match:->combinators
 (define-test ()
   (assert-equal
    ((match:->combinators `(a ((? b ,number?) 2 3) (? b) c))
     '((a (1 2 3) 1 c))
     '()
     (lambda (x y) `(succeed ,x ,y)))
    '(succeed ((b 1)) 1)))
 (define-test ()
   (assert-equal
    ((match:->combinators `(a ((? b ,number?) 2 3) (? b) c))
     '((a (foo 2 3) foo c))
     '()
     (lambda (x y) `(succeed ,x ,y)))
    #f))
 (define-test ()
   (assert-equal
    ((match:->combinators `(a ((? b) 2 3) (? b ,number?) c))
     '((a (foo 2 3) foo c))
     '()
     (lambda (x y) `(succeed ,x ,y)))
    #f))
 )

;; Problem 3.4

(define (match:choice . match-combinators)
  (define (choice-match data dictionary succeed)
    (let lp ((matchers match-combinators))
      (and (not (null? matchers))
           (or ((car matchers) data dictionary succeed)
               (lp (cdr matchers))))))
  choice-match)

(define (match:choice? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?:choice)))

(define (match:choices pattern)
  (cdr pattern))

(define (match:->combinators pattern)
  (define (compile pattern)
    (cond ((match:element-restricted? pattern)
           (match:element-restricted (match:variable-name pattern) (match:predicate pattern)))
          ((match:element? pattern)
           (match:element (match:variable-name pattern)))
          ((match:segment? pattern)
           (match:segment (match:variable-name pattern)))
          ((match:choice? pattern)
           (apply match:choice (map compile (match:choices pattern))))
          ((list? pattern)
           (apply match:list (map compile pattern)))
          (else (match:eqv pattern))))
  (compile pattern))

(in-test-group
 match:?choice
 (define-test ()
   (assert-equal
    ((match:->combinators '(?:choice a b (? x) c))
     '(z)
     '()
     (lambda (d n) `(succeed ,d ,n)))
    '(succeed ((x z)) 1)))
 (define-test ()
   (assert-equal
    ((match:->combinators `((? y) (?:choice a b (? x ,string?) (? y ,symbol?) c)))
     '((z z))
     '()
     (lambda (d n) `(succeed ,d ,n)))
    '(succeed ((y z)) 1)))
 (define-test ()
   (assert-equal
    (let ((res '()))
      ((match:->combinators `(?:choice b (? x ,symbol?)))
      '(b)
      '()
      (lambda (x y)
        (set! res (cons `(succeed ,x ,y) res))
      #f))
      (reverse res))
    '((succeed () 1)
      (succeed ((x b)) 1))))
 )

;; Problem 3.5

#|

I extend the dictionary so that, in addition to storing variables, it
will store environment patterns. In order to minimize changes to the
code, variables are still stored with the key <variable>. Environment
patterns are stored with the key ('env <variable>).

|#

(define (tag-env variable)
  (list 'env variable))

(define (match:bind-env variable data-object dictionary)
  (match:bind (tag-env variable) data-object dictionary))

(define (match:lookup-env variable dictionary)
  ;; this won't work because match:lookup uses assoq
  ;; and the key is a list
  ;;(match:lookup (tag-env variable) dictionary))
  (assoc (tag-env variable) dictionary))

(define (match:pletrec? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?:pletrec)))

(define (match:bind-definitions names combinators dictionary)
  (if (null? names)
      dictionary
      (match:bind-definitions 
       (cdr names)
       (cdr combinators)
       (match:bind-env (car names)
                       (car combinators)
                       dictionary))))

(define (match:pletrec names combinators body-combinator)
  (define (pletrec-match data dictionary succeed)
    (body-combinator
     data
     (match:bind-definitions names combinators dictionary)
     succeed))
  pletrec-match)

(define (match:parse-pletrec pattern)
  (define definitions (cadr pattern))
  (define body (caddr pattern))
  (define (def:name def) (car def))
  (define (def:pattern def) (cadr def))
  (define (def:combinator def) 
    (match:->combinators (def:pattern def)))
  (let ((names-combinators
         (if (null? definitions)
             (list '() '())
             (apply zip 
                    (map (lambda (def) 
                           (list (def:name def) 
                                 (def:combinator def))) 
                         definitions)))))
    (match:pletrec 
     (car names-combinators) 
     (cadr names-combinators)
     (match:->combinators body))))

(define (match:ref? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?:ref)))

(define (match:ref-name pattern)
  (cadr pattern))

(define (match:ref name)
  (define (ref-match data dictionary succeed)
    (let ((vcell (match:lookup-env name dictionary)))
      (if (not vcell)
          (error "?:ref: reference to unbounded pattern name, " name)
          ((match:value vcell) data dictionary succeed))))
  ref-match)

(define (match:->combinators pattern)
  (define (compile pattern)
    (cond ((match:element-restricted? pattern)
           (match:element-restricted (match:variable-name pattern) (match:predicate pattern)))
          ((match:element? pattern)
           (match:element (match:variable-name pattern)))
          ((match:segment? pattern)
           (match:segment (match:variable-name pattern)))
          ((match:choice? pattern)
           (apply match:choice (map compile (match:choices pattern))))
          ((match:pletrec? pattern)
           (match:parse-pletrec pattern))
          ((match:ref? pattern)
           (match:ref (match:ref-name pattern)))
          ((list? pattern)
           (apply match:list (map compile pattern)))
          (else (match:eqv pattern))))
  (compile pattern))

(define (remove-env dictionary)
  (filter 
   (lambda (x)
     (if (and (pair? (car x))
              (eq? (caar x) 'env))
         #f
         #t))
   dictionary))

(define (test-match combinator-def what)
  ((match:->combinators combinator-def)
   (list what)
   '()
    (lambda (x y) `(succeed ,(remove-env x) ,y))))

(in-test-group
 match:?pletrec
   (define-test (odd-even)
     (let ((fancy-combinator
          '(?:pletrec ((odd-even-etc (?:choice () (1 (?:ref even-odd-etc))))
               (even-odd-etc (?:choice () (2 (?:ref odd-even-etc)))))
              (?:ref odd-even-etc))))
       (assert-equal
        (test-match fancy-combinator '())
        '(succeed () 1))
       (assert-equal
        (test-match fancy-combinator '(1 (2 ())))
        '(succeed () 1))
       (assert-equal
        (test-match fancy-combinator '(1 (2 (2 ()))))
        #f)))
   (define-test ()
     (assert-equal
      (test-match
       `(?:pletrec ()
                   (a ((? b ,number?) 2 3) (? b) c))
       '(a (1 2 3) 1 c))
      '(succeed ((b 1)) 1))
     (assert-equal
      (test-match
       `(?:pletrec 
         ((a a))
         ((?:ref a) ((? b ,number?) 2 3) (? b) c))
       '(a (1 2 3) 1 c))
      '(succeed ((b 1)) 1))
     (assert-equal
      (test-match
       `(?:pletrec 
         ((a a)
          (b (? b ,number?)))
         ((?:ref a) ((?:ref b) 2 3) (? b) c))
       '(a (1 2 3) 1 c))
      '(succeed ((b 1)) 1)))
   )

;; Problem 3.6

(define (match:restrict? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?:restrict)))

(define (match:restrict-predicate pattern)
  (cadr pattern))

(define (match:restrict predicate)
  (define (restrict-match data dictionary succeed)
    (and (pair? data)
         (and (predicate (car data))
              (succeed dictionary 1))))
  restrict-match)

(define (match:->combinators pattern)
  (define (compile pattern)
    (cond ((match:element-restricted? pattern)
           (match:element-restricted (match:variable-name pattern) (match:predicate pattern)))
          ((match:element? pattern)
           (match:element (match:variable-name pattern)))
          ((match:segment? pattern)
           (match:segment (match:variable-name pattern)))
          ((match:choice? pattern)
           (apply match:choice (map compile (match:choices pattern))))
          ((match:pletrec? pattern)
           (match:parse-pletrec pattern))
          ((match:ref? pattern)
           (match:ref (match:ref-name pattern)))
          ((match:restrict? pattern)
           (match:restrict (match:restrict-predicate pattern)))
          ((list? pattern)
           (apply match:list (map compile pattern)))
          (else (match:eqv pattern))))
  (compile pattern))

(in-test-group
 match:?restrict
 (define-test ()
   (let ((tree-combinator
          `(?:pletrec ((btos 
                        (?:choice ()
                                  (?:restrict ,symbol?)
                                  ((?:ref btos) (?:ref btos)))))
                      (binary tree of symbols:  (?:ref btos)))))
     (assert-equal
      (test-match
       tree-combinator
       '(binary tree of symbols:  ()))
      '(succeed () 1))
     (assert-equal
      (test-match
       tree-combinator
       '(binary tree of symbols:  (a b)))
      '(succeed () 1))
     (assert-equal
      (test-match
       tree-combinator
       '(binary tree of symbols:  ((a b) (c))))
      #f)
     (assert-equal
      (test-match
       tree-combinator
       '(binary tree of symbols:  (a 2)))
      #f)))
 )

(run-registered-tests)
;; 12 tests, 0 failures, 0 errors.