;; AUTHOR: Gary T. Leavens

(define deep-recur-abs
  ; TYPE: (-> (T (-> (S T) T) (-> (T T) T) (-> datum boolean))
  ;           (-> ((tree S)) T))
  (lambda (seed flat-proc tree-proc leaf?)
    ; REQUIRES: (leaf? x) = (x has type S)
    ; ENSURES: (result '()) = seed,
    ;          (result (cons x t))  = (flat-proc x (result t)),
    ;          (result (cons t1 t2)) = (tree-proc (result t1) (result t2))
    ;          where (leaf? x) holds, but not (leaf? t1) and (leaf? t2).
    (letrec
      ((helper  ; TYPE: (-> ((tree S)) T)
         (lambda (tr)
           (if (null? tr)
               seed
               (let ((a (car tr)))
                 (if (leaf? a)
                     (flat-proc a (helper (cdr tr)))
                     (tree-proc (helper a) (helper (cdr tr)))))))))
      helper)))


;; The following allows easy creation of deep recursions schemes over
;; "trees of S", by using a leaf? predicate that tests for type S.

(define deep-recur-abs-m
  ; TYPE: (-> ((-> datum boolean))
  ;           (-> (T (-> (S T) T) (-> (T T) T) (-> ((tree S)) T))))
  (lambda (leaf?)
    (lambda (seed flat-proc tree-proc)
      (deep-recur-abs seed flat-proc tree-proc leaf?))))


;; The following is the case of deep recursion over trees of atomic-items.
;; Compare with program 7.28

(define deep-recur
  ; TYPE: (-> (T (-> (S T) T) (-> (T T) T)) (-> ((tree S)) T))
  (let ((atomic-item?  ; TYPE: (-> (datum) boolean)
	     (lambda (x)
	       (not (or (pair? x)
			(null? x))))))
    ; REQUIRES: if x has type S, then (atomic-item? x) is true
    (deep-recur-abs-m atomic-item?)))