(use scheme0-pe)

(define ack '(
  (define (ack m n)
    (if (op equal? m 0) (op + n 1)
	(if (op equal? n 0)
	    (call ack (op - m 1) 1)
	    (call ack (op - m 1) (call ack m (op - n 1)))))
  )))

(pp (scheme ack))
(pp (scheme (monope ack '(S D) '(4))))

(define (snoc lis e)
  (if (null? lis)
      (cons e lis)
      (cons (car lis) (snoc (cdr lis) e))))

; Improved string matcher, using negative info (JGS Figure 12.3)
; Gives specialized matchers similar to Knuth-Morris-Pratt's

(define match3 (desugar '(

(define (match p d) (call loop p d p '() '() '()))

(define (loop p d pp f ff neg)
  (if (op null? p) 'yes
  (if (op null? f) 
      (if (op member (hd p) neg)
	  (if (op null? ff) 
	      (call match pp (tl d))
	      (call loop pp d pp (tl ff) (tl ff) neg))
      (if (if (op null? neg) (op null? d) #f) 'no
      (if (op equal? (hd p) (hd d)) 
	  (call loop (tl p) (tl d) pp '() (op snoc ff (hd p)) '())
      (if (op null? ff)
	  (call match pp (tl d))
	  (call loop pp d pp (tl ff) (tl ff) (op cons (hd p) neg))))))
  (if (op equal? (hd p) (hd f))
      (call loop (tl p) d pp (tl f) ff neg)
      (call loop pp d pp (tl ff) (tl ff) neg)
)))))))

(define pat1 '(a a a a a a a a a a a a a a a a a a b))

(pp (scheme (monope match3 '(S D) (list pat1))))