(load "~/public_html/symbolic/03/matcher.scm")

;;;; problems 3.1 and 3.2

(define match:succeed-true
  (lambda (x y) (= y 1)))

(define match:succeed-dictionary
  (lambda (x y) `(succeed ,x)))

(define (match:element-restricted variable restriction?)
  (define (element-match data dictionary succeed)
    (and (pair? data)                   ;there is some data left
         (let ((vcell (match:lookup variable dictionary))) ;
           (if vcell
               (and (equal? (match:value vcell) (car data))
                    (succeed dictionary 1))
               (and (restriction? (car data))
                    (succeed (match:bind variable (car data) dictionary)
                             1))))))
  element-match)

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

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


#||

((match:->combinators `(a
                        (? b ,(lambda (x) (eqv? (car x)
                                           1)))
                        (?? c)
                        c))
 
 '((a (1 2 3) 2 c))
 '()
 match:succeed-dictionary)
;Value: (succeed ((c (2)) (b (1 2 3))) 1)

((match:->combinators `(a
                        (? b ,(lambda (x) (eqv? (car x)
                                           2)))
                        (?? c)
                        c))
 
 '((a (1 2 3) 2 c))
 '()
 match:succeed-dictionary)
;Value: #f


(define (sin-squared? pattern)
  ((match:->combinators `((square (sin (? b)))))
 `((,pattern))
 '()
 match:succeed-true))

(define (cos-squared? pattern)
  ((match:->combinators `((square (cos (? b)))))
   `((,pattern))
   '()
   match:succeed-true))


((match:->combinators `((?? a)
                        (? x ,sin-squared?)
                        (?? b)
                        (? y ,cos-squared?)
                        (?? c)))
 '((+ aa bb
      (square (sin xx))
      cc dd
      (square (cos yy))
      ee ff))
 '()
 match:succeed-dictionary)
;Value: (succeed ((c (ee ff)) (y (square (cos yy))) (b (cc dd)) (x
;(square (sin xx))) (a (+ aa bb))) 1)

((match:->combinators `((?? a)
                        (? x ,sin-squared?)
                        (?? b)
                        (? y ,cos-squared?)
                        (?? c)))
 '((+ aa bb
      (square (cos xx))
      cc dd
      (square (cos yy))
      ee ff))
 '()
 match:succeed-dictionary)
;Value: #f

||#


;;;; problem 3.3

; Once the matcher comes up with a successful match using all of the
; data and all of the pattern it is at the bottom of a stack of scheme
; frames created by all the instances of match:segment that have been
; called.  Included in this stack is a stack of success continuations,
; which get sequentially popped off by being returned the final
; dictionary.  The final success continuation on the stack returns the
; value produced by calling the external success continuation with the
; final dictionary.  If the final continuation returns any value other
; than #f, the stack of scheme frames will vanish, since each one was
; created by an 'or.  But if the final continuation returns a #f, the
; evaluation only returns to the last 'or that was called, which is
; still holding the stack of success continuations that existed when
; it was called.  So the value gets passed up to the top level without
; losing the progam's place in the search tree by calling an external
; continuation with the final value rather than simply returning it.



;;;; problem 3.4


(define (match:reversed-segment variable)
  (define (reversed-segment-match data dictionary succeed)
    (and (list? data)
         (let ((vcell (match:lookup variable dictionary)))
           (and vcell
                (let* ((val (match:value vcell))
                       (len (length val)))
                  (and (>= (length data)
                           len)
                       (equal? (list-head data len)
                                (reverse val))
                       (succeed dictionary len)))))))
  reversed-segment-match)

(define (match:reversed-segment? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '$$)))

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

(define (even-palindrome? x)
  ((match:->combinators '((?? x) ($$ x)))
   (list x)
   '()
   match:succeed-true))

#||
((match:->combinators '((?? x) ($$ x)))
 '((a b c c b a))
 '()
 match:succeed-dictionary)
;Value: (succeed ((x (a b c))) 1)


(even-palindrome? '(a b c c b a))
;Value: #t


(even-palindrome? '(a b c c b x))
;Value: #f
||#