Commits

Moritz Heidkamp committed 12dd844

Initial commit

Comments (0)

Files changed (5)

+(load-relative "../zipper-impl.scm")
+
+(use test)
+
+(test-begin)
+
+(test-group "node, children, branch?"
+  (define z (list-zipper '(a b c)))
+  (test '(a b c) (node z))
+  (test '(a b c) (children z))
+  (test-assert (branch? z))
+  (test-assert (not (branch? (list-zipper 'x)))))
+
+(test-group "up, down, left, right, root, node"
+  (define z0 (list-zipper '(a (b c))))
+  (test '(a (b c)) (node z0))
+  
+  (define z1 (down z0))
+  (test 'a (node z1))
+
+  (define z2 (right z1))
+  (test '(b c) (node z2))
+
+  (define z3 (down z2))
+  (test 'b (node z3))
+
+  (define z4 (right z3))
+  (test 'c (node z4))
+
+  (define z5 (left z4))
+  (test (node z3) (node z5))
+
+  (define z6 (up z5))
+  (test (node z2) (node z6))
+
+  (define z7 (up z6))
+  (test (node z0) (node z7))
+  (test (node z0) (node (root z4))))
+
+(test-group "rightmost, leftmost"
+  (define z0 (list-zipper '(a b c d)))
+  (test (node z0) (node (leftmost z0)))
+  (test (node z0) (node (rightmost z0)))
+
+  (define z1 (down z0))
+  (define z2 (rightmost z1))
+  (test 'd (node z2))
+  (test 'a (node (leftmost z2))))
+
+
+(test-group "prepend-child, append-child, replace, edit"
+  (define z0 (list-zipper '(a (b (c)))))
+
+  (define z1 (right (down (right (down z0)))))
+  
+  (define z2 (prepend-child z1 'd))
+  (test '(d c) (node z2))
+  (test '(a (b (d c))) (node (root z2)))
+  (test '(a (b (c))) (node z0))
+
+  (define z3 (append-child z1 'd))
+  (test '(c d) (node z3))
+  (test '(a (b (c d))) (node (root z3)))
+  (test '(a (b (c))) (node z0))
+
+  (define z4 (replace z1 'd))
+  (test 'd (node z4))
+  (test '(a (b d)) (node (root z4)))
+  (test '(a (b (c))) (node z0))
+
+  (define z5 (edit z1 append '(d)))
+  (test '(c d) (node z5))
+  (test '(a (b (c d))) (node (root z5)))
+  (test '(a (b (c))) (node z0)))
+
+(test-group "insert-left, insert-right"
+  (define z0 (down (list-zipper '(c))))
+  
+  (define z1 (insert-left z0 'a))
+  (test '(a c) (node (root z1)))
+  
+  (define z2 (insert-left z1 'b))
+  (test '(a b c) (node (root z2)))
+
+  (define z3 (insert-right z2 'e))
+  (test '(a b c e) (node (root z3)))
+
+  (define z4 (insert-right z3 'd))
+  (test '(a b c d e) (node (root z4))))
+
+(test-end)
+
+(test-exit)
+;; A (mostly) direct port of Rich Hickey's clojure.zip library
+;;
+;; Copyright (c) 2013, Moritz Heidkamp. All rights reserved.
+;;
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0
+;; (http://opensource.org/licenses/eclipse-1.0.php) which can be found
+;; in the file COPYING at the root of this distribution. By using this
+;; software in any fashion, you are agreeing to be bound by the terms
+;; of this license.
+;;
+;; You must not remove this notice, or any other, from this software.
+
+(use (only srfi-1 last))
+
+(define-record-type zipper
+  (make-zipper impl node path)
+  zipper?
+  (impl zipper-impl)
+  (node loc-node)
+  (path loc-path))
+
+(define-record-type zipper-impl
+  (make-impl name branch? children make-node)
+  impl?
+  (name zipper-name)
+  (branch? zipper-branch?)
+  (children zipper-children)
+  (make-node zipper-make-node))
+
+(define-record-type zipper-path
+  (make-path left pnodes ppath changed? right)
+  path?
+  (left path-left)
+  (pnodes path-pnodes)
+  (ppath path-ppath)
+  (changed? path-changed?)
+  (right path-right))
+
+(define-record-printer (zipper x out)
+  (display "#<" out)
+  (display (zipper-name (zipper-impl x)) out)
+  (display " " out)
+  (write (loc-node x) out)
+  (display ">" out))
+
+(define (copy-loc loc
+                  #!key
+                  (node (loc-node loc))
+                  (path (loc-path loc)))
+  (make-zipper (zipper-impl loc)
+               node
+               path))
+
+(define (copy-path path
+                   #!key
+                   (left (path-left path))
+                   (pnodes (path-pnodes path))
+                   (ppath (path-ppath path))
+                   (changed (path-changed? path))
+                   (right (path-right path)))
+  (make-path left
+             pnodes
+             ppath
+             changed
+             right))
+
+(define (scoped loc)
+  (make-zipper (zipper-impl loc) (node loc) #f))
+
+
+(define node
+  loc-node)
+
+(define (zipper branch? children #!optional make-node (name 'zipper))
+  (let ((impl (make-impl name branch? children make-node)))
+    (lambda (root)
+      (make-zipper impl root #f))))
+
+(define list-zipper
+  (zipper list?
+          values
+          (lambda (node children)
+            children)
+          'list-zipper))
+
+(define (branch? loc)
+  ((zipper-branch? (zipper-impl loc)) (node loc)))
+
+(define (make-node loc node children)
+  ((zipper-make-node (zipper-impl loc)) node children))
+
+(define (children loc)
+  (if (branch? loc)
+      ((zipper-children (zipper-impl loc)) (node loc))
+      (error 'children "Can't be called on a leaf node" loc)))
+
+(define (down loc)
+  (and (branch? loc)
+       (let ((cs (children loc)))
+         (and (pair? cs)
+              (let* ((path  (loc-path loc))
+                     (node  (loc-node loc))
+                     (cpath (make-path '()
+                                       (if path
+                                           (append (path-pnodes path)
+                                                   (list node))
+                                           (list node))
+                                       path
+                                       #f
+                                       (cdr cs))))
+                (copy-loc loc
+                          node: (car cs)
+                          path: cpath))))))
+
+(define (up loc)
+  (and-let* ((path   (loc-path loc))
+             (pnodes (path-pnodes path)))
+    (let ((changed? (path-changed? path))
+          (pnode    (last pnodes))
+          (ppath    (path-ppath path)))
+      (copy-loc loc
+                node: (if changed?
+                          (make-node loc
+                                     pnode
+                                     (append (path-left path)
+                                             (cons (loc-node loc)
+                                                   (path-right path))))
+                          pnode)
+                path: (if changed?
+                          (and ppath (copy-path ppath changed: #t))
+                          ppath)))))
+
+(define ((horizontal-navigation nodes new-node new-path) loc)
+  (and-let* ((path (loc-path loc))
+             (ns   (nodes path)))
+    (and (pair? ns)
+         (copy-loc loc
+                   node: (new-node ns)
+                   path: (apply copy-path
+                                path
+                                (new-path ns (loc-node loc) path))))))
+
+(define left
+  (horizontal-navigation
+   path-left
+   last
+   (lambda (ls node path)
+     (list left: (butlast ls)
+           right: (cons node (path-right path))))))
+
+(define leftmost*
+  (horizontal-navigation
+   path-left
+   car
+   (lambda (ls node path)
+     (list left: '()
+           right: (append (cdr ls)
+                          (list node)
+                          (path-right path))))))
+
+(define (leftmost loc)
+  (or (leftmost* loc) loc))
+
+(define right
+  (horizontal-navigation
+   path-right
+   car
+   (lambda (rs node path)
+     (list left: (append (path-left path) (list node))
+           right: (cdr rs)))))
+
+(define rightmost*
+  (horizontal-navigation
+   path-right
+   last
+   (lambda (rs node path)
+     (list left: (append (path-left path)
+                         (list node)
+                         (butlast rs))
+           right: '()))))
+
+(define (rightmost loc)
+  (or (rightmost* loc) loc))
+
+(define (end? loc)
+  (eqv? 'end (loc-path loc)))
+
+(define (next loc)
+  (or (and (branch? loc) (down loc))
+      (right loc)
+      (let loop ((loc loc))
+        (let ((p (up loc)))
+          (if p
+              (or (right p) (loop p))
+              (copy-loc loc path: 'end))))))
+
+(define (root loc)
+  (let ((p (up loc)))
+    (if p (root p) loc)))
+
+(define (ensure-editable! location zipper)
+  (unless (zipper-make-node (zipper-impl zipper))
+    (error location "Zipper is not editable" zipper)))
+
+(define (%replace loc node)
+  (copy-loc loc
+            node: node
+            path: (and-let* ((path (loc-path loc)))
+                    (copy-path path changed: #t))))
+
+(define (replace loc node)
+  (ensure-editable! 'replace loc)
+  (%replace loc node))
+
+(define (edit loc f . args)
+  (ensure-editable! 'edit loc)
+  (%replace loc (apply f (node loc) args)))
+
+(define (update-node loc f . args)
+  (%replace loc (make-node loc (node loc) (apply f args))))
+
+(define (prepend-child loc child)
+  (ensure-editable! 'prepend-child loc)
+  (update-node loc (lambda () (cons child (children loc)))))
+
+(define (append-child loc child)
+  (ensure-editable! 'append-child loc)
+  (update-node loc (lambda () (append (children loc) (list child)))))
+
+(define ((insert-sibling name new-path) loc sibling)
+  (ensure-editable! name loc)
+  (let ((path (loc-path loc)))
+    (if path
+        (copy-loc loc path: (new-path path sibling))
+        (error name "Sibling insertion at root is not possible" loc sibling))))
+
+(define insert-left
+  (insert-sibling
+   'insert-left
+   (lambda (path sibling)
+     (let ((left (append (path-left path) (list sibling))))
+       (copy-path path left: left changed: #t)))))
+
+(define insert-right
+  (insert-sibling
+   'insert-right
+   (lambda (path sibling)
+     (let ((right (cons sibling (path-right path))))
+       (copy-path path right: right changed: #t)))))
+
+(define (find-all loc pred?)
+  (let loop ((loc (scoped loc)))
+    (if (end? loc)
+        '()
+        (if (pred? loc)
+            (cons loc (loop (next loc)))
+            (loop (next loc))))))
+((synopsis "Zippers")
+ (author "Moritz Heidkamp")
+ (category data)
+ (license "BSD")
+ (depends)
+ (test-depends)
+ (foreign-depends))
+(module zipper
+
+()
+
+(import chicken scheme)
+
+"zipper-impl.scm"
+
+)
+(compile -d0 -O2 -J -s zipper.scm)
+(compile -d0 -O2 -s zipper.import.scm)
+
+(install-extension
+ 'zipper
+ '("zipper.so" "zipper.import.so")
+ '((version "0.0.1")))