zipper.scm

;; zipper.scm
;; A binary tree zipper implementation in Scheme
;; Author: Eugene Ma (edma2)

(define (make-tree datum left right)
  (list datum left right))
(define datum car)
(define left-child cadr)
(define right-child caddr)
(define (make-leaf datum)
  (make-tree datum '() '()))

(define (has-left-child? t)
  (not (eq? '() (left-child t))))

(define (has-right-child? t)
  (not (eq? '() (right-child t))))

(define (make-context which-branch other-branch parent-datum parent-context)
  (list which-branch other-branch parent-datum parent-context))
(define which-branch car)
(define other-branch cadr)
(define parent-datum caddr)
(define parent-context cadddr)
(define top-context '())

(define (make-loc tree context)
  (list tree context))
(define loc-tree car)
(define loc-context cadr)

(define (go-left loc)
  (let ((parent-tree (loc-tree loc)))
    (make-loc (left-child parent-tree)
              (make-context 'right
                            (right-child parent-tree)
                            (datum parent-tree)
                            (loc-context loc)))))

(define (go-right loc)
  (let ((parent-tree (loc-tree loc)))
    (make-loc (right-child parent-tree)
              (make-context 'left
                            (left-child parent-tree)
                            (datum parent-tree)
                            (loc-context loc)))))

(define (go-up loc)
  (let ((context (loc-context loc))
        (tree (loc-tree loc)))
    (make-loc (if (eq? (which-branch loc) 'left)
                (make-tree (parent-datum context) (other-branch context) tree)
                (make-tree (parent-datum context) tree (other-branch context)))
              (parent-context context))))

(define (update loc fn)
  (make-loc (fn (loc-tree loc))
            (loc-context loc)))

(define (make-zipper root)
  (make-loc root top-context))

(define (sum t)
  ;; Returns the sum of node at t and its children, recursively
  (+ (datum t)
     (if (has-left-child? t) (sum (left-child t)) 0)
     (if (has-right-child? t) (sum (right-child t)) 0)))

(define (zipper-dfs z f)
  ;; Applies f to every node of z
  (let ((updated-z (update z f)))
    (let ((updated-z
            (if (has-left-child? (loc-tree updated-z))
              (go-up (zipper-dfs (go-left updated-z) f))
              updated-z)))
      (if (has-right-child? (loc-tree updated-z))
        (go-up (zipper-dfs (go-right updated-z) f))
        updated-z))))

(define t (make-tree 4 
                     (make-tree 5
                                (make-leaf 2) (make-leaf 7)) 
                     (make-tree 9
                                (make-leaf 13) (make-leaf 1))))
(define z (make-zipper t))