Zippers in Scheme

README.md

Zippers

Please see https://github.com/thunknyc/scm-zipper.

zipper.scm

;;;
;;; Zippers
;;;
;;; Edwin Watkeys
;;; Thunk NYC Corp.
;;; edw@poseur.com
;;;
;;; 2018-12-18
;;;

;;; Depends on (import (scheme red)). Example code at the bottom.

;;; Code to abstract away collection types. Add COND cases to support
;;; additional collections such as vectors, hash-tables, sets, bags.

(define (collection? col)
  (and (list? col) (not (null? col))))

(define (first col)
  (cond ((list? col) (car col))))

(define (rest col)
  (cond ((list? col) (cdr col))))

(define (final col)
  (cond ((list? col) (last col))))

(define (drop-final col)
  (cond ((list? col) (drop-right col 1))))

(define (empty col)
  (cond ((list? col) '())))

(define (prepend a col)
  (cond ((list? col) (cons a col))))

(define (construct col els)
  (cond ((list? col) els)))

(define (len col)
  (cond ((list? col) (length col))))

(define (xlate-seq-ref col i)
  (if (>= i 0) i
      (+ (len col) i)))

(define (ref-in-domain? col i)
  (cond ((list? col)
         (let ((i (xlate-seq-ref col i)))
           (and (>= i 0) (< i (length col)))))))

(define (split-ref col i)
  (cond ((list? col)
         (let*-values (((i) (xlate-seq-ref col i))
                       ((a b) (split-at col i)))
           (values (car b) a (cdr b))))))

(define (dec n) (- n 1))

;;; Zipper implementation code

(define-record-type Zipper
  (make-zipper current left right above)
  zipper?
  (current zipper-current)
  (left zipper-left)
  (right zipper-right)
  (above zipper-above))

(define (zipper o)
  (make-zipper o '() '() '()))

(define (zip-down z)
  (let ((c (zipper-current z))
        (l (zipper-left z))
        (r (zipper-right z))
        (a (zipper-above z)))
    (cond ((collection? c)
           (make-zipper (first c) (empty c) (rest c) z))
          (else
           (error "Cannot zip down from here" z c)))))

(define (zip-to-ref z i . o)
  (let ((fail (if (pair? o) (car o)
                  (lambda ()
                    (error "Reference does not exist in collection"
                      i col))))
        (c (zipper-current z))
        (l (zipper-left z))
        (r (zipper-right z))
        (a (zipper-above z)))
    (let ((col (construct l `(,@l ,c ,@r))))
      (cond ((ref-in-domain? col i)
             (let-values (((c l r) (split-ref col i)))
               (make-zipper c l r a)))
            (else
             (fail))))))

(define (zip-left z . o)
  (let loop ((n (if (pair? o) (car o) 1)) (z z))
    (cond ((<= n 0) z)
          (else
           (let ((c (zipper-current z))
                 (l (zipper-left z))
                 (r (zipper-right z))
                 (a (zipper-above z)))
             (cond ((collection? l)
                    (loop (dec n) (make-zipper (final l)
                                               (drop-final l)
                                               (prepend c r) a)))
                   (else
                    (error "Cannot zip left from here" z c))))))))

(define (zip-right z . o)
  (let loop ((n (if (pair? o) (car o) 1)) (z z))
    (cond ((<= n 0) z)
          (else
           (let ((c (zipper-current z))
                 (l (zipper-left z))
                 (r (zipper-right z))
                 (a (zipper-above z)))
             (cond ((collection? r)
                    (loop (dec n) (make-zipper (first r)
                                               (construct r `(,@l ,c))
                                               (rest r) a)))
                   (else
                    (error "Cannot zip right from here" z c))))))))

(define (zipper-top? z)
  (null? (zipper-above z)))

(define (zip-up z)
  (let ((c (zipper-current z))
        (l (zipper-left z))
        (r (zipper-right z))
        (a (zipper-above z)))
    (cond ((zipper-top? z)
           (error "Cannot zip up from here" z c))
          (else
           (let ((al (zipper-left a))
                 (ar (zipper-right a))
                 (aa (zipper-above a)))
             (make-zipper (construct l `(,@l ,c ,@r)) al ar aa))))))

(define (zip-update z proc)
  (let ((c (zipper-current z))
        (l (zipper-left z))
        (r (zipper-right z))
        (a (zipper-above z)))
    (make-zipper (proc c) l r a)))

(define (zip-swap z new)
  (zip-update z (lambda (ignore) new)))

(define (zip-top z)
  (if (zipper-top? z) z
      (zip-top (zip-up z))))

(define (unzip z)
  (zipper-current (zip-top z)))

;;; Demonstration code

(define-syntax ->
  (syntax-rules ()
    ((_ val (proc arg ...) form ...)
     (-> (proc val arg ...) form ...))
    ((_ val proc form ...)
     (-> (proc val) form ...))
    ((_ val)
     val)))

(let ((update (lambda (el) (string-upcase (symbol->string el)))))
  (-> (zipper '(a (b c d e) f g))
      zip-down
      (zip-right 2)
      (zip-update update)
      zip-left
      zip-down
      (zip-to-ref -1)
      (zip-update update)
      (zip-left 3)
      (zip-swap 'was-b)
      unzip))