├── .gitignore ├── tests ├── packages.lisp └── zipper-tests.lisp ├── src ├── packages.lisp └── zipper.lisp ├── cl-zipper.asd ├── COPYING └── README.markdown /.gitignore: -------------------------------------------------------------------------------- 1 | # Emacs temporary files 2 | *# 3 | -------------------------------------------------------------------------------- /tests/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-zipper.tests 2 | (:documentation "Provides tests for the zipper library.") 3 | (:use :cl :cl-zipper :5am)) 4 | 5 | (in-package :cl-zipper.tests) 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (unless (get-test :cl-zipper) 9 | (def-suite :cl-zipper))) -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-zipper 2 | (:documentation "Provides the zipper library.") 3 | (:use :cl) 4 | (:export :append-down 5 | :change-node 6 | :edit-node 7 | :go-down 8 | :go-left 9 | :go-next 10 | :go-prev 11 | :go-right 12 | :go-up 13 | :insert-down 14 | :insert-left 15 | :insert-right 16 | :leftmost 17 | :lefts 18 | :path 19 | :remove-node 20 | :rightmost 21 | :rights 22 | :root-node 23 | :zipper)) -------------------------------------------------------------------------------- /cl-zipper.asd: -------------------------------------------------------------------------------- 1 | (defpackage :cl-zipper-system 2 | (:use :cl :asdf)) 3 | 4 | (in-package :cl-zipper-system) 5 | 6 | (defsystem :cl-zipper 7 | :description "Common Lisp implementation of Gérard Huet's Zippers." 8 | :version "0.1" 9 | :author "Daniel Fernandes Martins " 10 | :license "BSD" 11 | :components ((:module "src" 12 | :serial t 13 | :components ((:file "packages") 14 | (:file "zipper"))) 15 | (:static-file "README.rst") 16 | (:static-file "COPYING")) 17 | :in-order-to ((asdf:test-op (load-op :cl-zipper.tests)))) 18 | 19 | (defsystem :cl-zipper.tests 20 | :depends-on (:fiveam :cl-zipper) 21 | :components ((:module "tests" 22 | :serial t 23 | :components ((:file "packages") 24 | (:file "zipper-tests"))))) 25 | 26 | (defmethod asdf:perform :after ((op asdf:test-op) (c (eql (asdf:find-system :cl-zipper)))) 27 | "Runs the tests when test-op is issued for :cl-zipper." 28 | (funcall (find-symbol (string :run!) :cl-zipper.tests))) 29 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2012, Daniel Fernandes Martins 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of Daniel Fernandes Martins nor the names of 15 | its contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 22 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 23 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 24 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 25 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # cl-zipper 2 | 3 | cl-zipper is a Common Lisp implementation of the Zipper data structure first 4 | described by [Gerárd Huet](http://www.st.cs.uni-saarland.de/edu/seminare/2005/advanced-fp/docs/huet-zipper.pdf). 5 | 6 | ## Supported Implementations 7 | 8 | The code was tested and runs successfuly on each of the following 9 | Common Lisp platforms: 10 | 11 | * [Clozure CL](http://ccl.clozure.com/) 12 | * [SBCL](http://www.sbcl.org/) 13 | * [CLISP](http://www.gnu.org/software/clisp/) 14 | 15 | ## Runtime Dependencies 16 | 17 | First, make sure that you have 18 | [ASDF](http://common-lisp.net/project/asdf/) installed and loaded: 19 | 20 | ````common-lisp 21 | > (asdf:asdf-version) 22 | "2.017" 23 | ```` 24 | 25 | A simple way to get ASDF is via 26 | [QuickLisp](http://www.quicklisp.org/beta/), which is a library 27 | manager for Common Lisp. 28 | 29 | ## Installing cl-zipper 30 | 31 | At this moment the package is not yet available for download through 32 | QuickLisp. 33 | 34 | However, it could be installed rather easily by cloning the project 35 | inside `~/quicklisp/local-projects` directory and running 36 | `(ql:quickload :cl-zipper)` in the REPL. 37 | 38 | ## Getting Started 39 | 40 | First, start a REPL and load the system: 41 | 42 | ````common-lisp 43 | (asdf:load-system :cl-zipper) 44 | (use-package :cl-zipper) 45 | ```` 46 | 47 | Suppose we have the tree `(a + b) * (c - d)` to play with: 48 | 49 | ````common-lisp 50 | (defparameter *loc* (zipper '(* (+ a b) (- c d)))) 51 | ```` 52 | 53 | ### Navigation Primitives 54 | 55 | Now, let's examine the four basic zipper operations: `(go-down loc)`, 56 | `(go-right loc)`, `(go-left loc)`, and `(go-up loc)`. 57 | 58 | Every zipper operation gets what we call a _loc_, or location, which 59 | consists in the current focus of attention within the tree, and the 60 | return value is a _loc_ that represents the new location after such 61 | operation is performed. 62 | 63 | For instance, let's take a look at what `(go-down loc)` does: 64 | 65 | ````common-lisp 66 | > (documentation 'go-down 'function) 67 | "Returns the loc of the leftmost child of the node at this loc, or 68 | nil if no children." 69 | ```` 70 | 71 | Obtaining more information about the current _loc_ and its 72 | surroundings: 73 | 74 | ````common-lisp 75 | (defparameter *loc-down* (go-down *loc*)) 76 | 77 | (car *loc-down*) ;; * 78 | (lefts *loc-down*) ;; NIL 79 | (rights *loc-down*) ;; ((+ A B) (- C D)) 80 | ```` 81 | 82 | The nice thing about this kind of abstraction is that you can navigate 83 | a tree by chaining calls: 84 | 85 | ````common-lisp 86 | (defparameter *loc-down-right* (go-right *loc-down*)) 87 | 88 | (car *loc-down-right*) ;; (+ A B) 89 | (lefts *loc-down-right*) ;; (*) 90 | (rights *loc-down-right*) ;; ((- C D)) 91 | ```` 92 | 93 | By now you probably have guessed what the other basic navigation 94 | primitives do: 95 | 96 | ````common-lisp 97 | > (documentation 'go-left 'function) 98 | "Returns the loc of the left sibling of the node at this loc, 99 | or nil." 100 | ```` 101 | 102 | To zip up to the parent node of a nested _loc_: 103 | 104 | ````common-lisp 105 | (car (go-up *loc-down-right*)) ;; (* (+ A B) (- C D)) 106 | ```` 107 | 108 | ### Navigation Shortcuts 109 | 110 | Use `(go-next loc)` if you just want to visit the nodes of 111 | the tree in depth-first order: 112 | 113 | ````common-lisp 114 | (defparameter *loc-next-2* (go-next (go-next *loc*))) 115 | 116 | (car *loc-next-2*) ;; (+ A B) 117 | (lefts *loc-next-2*) ;; (*) 118 | (rights *loc-next-2*) ;; (- C D) 119 | ```` 120 | 121 | Similarly, use `(go-prev loc)` to walk to the opposite direction: 122 | 123 | ````common-lisp 124 | (defparameter *loc-next* (go-prev *loc-next-2*)) 125 | 126 | (car *loc-next*) ;; * 127 | (lefts *loc-next*) ;; NIL 128 | (rights *loc-next*) ;; ((+ A B) (- C D)) 129 | ```` 130 | 131 | Now, suppose you have a _loc_ that points to `A`: 132 | 133 | ````common-lisp 134 | (defparameter *loc-a* (go-right (go-down (go-right (go-down *loc*))))) 135 | 136 | (car *loc-a*) ;; A 137 | (lefts *loc-a*) ;; (+) 138 | (rights *loc-a*) ;; (B) 139 | ````` 140 | 141 | You can get the leftmost or rightmost _loc_ with a simple function 142 | call: 143 | 144 | ````common-lisp 145 | (car (leftmost *loc-a*)) ;; + 146 | (car (rightmost *loc-a*)) ;; B 147 | ```` 148 | 149 | ### Removing Nodes 150 | 151 | Just call `(remove-node loc)` to remove the node at _loc_: 152 | 153 | ````common-lisp 154 | (root-node (remove-node *loc-a*)) ;; (* (+ B) (- C D)) 155 | ```` 156 | 157 | ### Inserting Nodes 158 | 159 | The first functions we'll see are `(insert-left loc node)` and 160 | `(insert-right loc node)`: 161 | 162 | ````common-lisp 163 | (root-node (insert-left *loc-a* 'x)) ;; (* (+ X A B) (- C D)) 164 | (root-node (insert-right *loc-a* 'x)) ;; (* (+ A X B) (- C D)) 165 | ```` 166 | 167 | If the node at _loc_ is the root of a subtree, it's possible to 168 | insert child nodes with `(append-down loc node)` and 169 | `(insert-down loc node)`. 170 | 171 | The `(append-down loc node)` function inserts a node as the rightmost 172 | child of the node at _loc_: 173 | 174 | ````common-lisp 175 | (defparameter *loc-subtree* (go-right (go-down *loc*))) 176 | (root-node (append-down *loc-subtree* '(/ x y))) ;; (* (+ A B (/ X Y)) (- C D)) 177 | ```` 178 | 179 | Use `(insert-down loc node)` to insert a node as the leftmost child: 180 | 181 | ````common-lisp 182 | (root-node (insert-down *loc-subtree* '(/ x y))) ;; (* ((/ X Y) + A B) (- C D)) 183 | ```` 184 | 185 | ### Changing Nodes 186 | 187 | Use `(change-node loc node)` in order to replace the node at _loc_: 188 | 189 | ````common-lisp 190 | (root-node (change-node *loc-a* 'x)) ;; (* (+ X B) (- C D)) 191 | ```` 192 | 193 | If the change is modeled by a function, the function 194 | `(edit-node loc func &rest args)` replaces the node at _loc_ with the 195 | result of applying `(func (car loc) arg1 arg2 ... argN)`: 196 | 197 | ````common-lisp 198 | (defun crazy-fn (node n1 n2) 199 | (if (equal node 'A) 200 | n1 201 | n2)) 202 | 203 | (root-node (edit-node *loc-a* #'crazy-fn 1 2)) ;; (* (+ 1 B) (- C D)) 204 | ```` 205 | 206 | ### Zippers Are Functional 207 | 208 | With zippers you can write code that looks like an imperative, 209 | destructive walk through a tree, call `(root-node loc)` when you are 210 | done and get a new tree reflecting all the changes, when in fact nothing 211 | at all is mutated - it's all thread safe and shareable. 212 | 213 | ## Contributing 214 | 215 | If you found bugs or want to add new features to cl-zipper, the first 216 | step is to write tests that cover your changes. 217 | 218 | As you'll see in a moment, [5am](http://www.cliki.net/FIVEAM) testing 219 | framework is required in order to run the tests. 220 | 221 | Now, clone this repository and open Lisp REPL at its root directory: 222 | 223 | ````common-lisp 224 | > (ql:quickload :fiveam) 225 | ... 226 | (:FIVEAM) 227 | 228 | > (asdf:test-system :cl-zipper) 229 | ... 230 | T 231 | ```` 232 | 233 | ## Donate 234 | 235 | If this project is useful for you, buy me a beer! 236 | 237 | Bitcoin: `bc1qtwyfcj7pssk0krn5wyfaca47caar6nk9yyc4mu` 238 | 239 | ## License 240 | 241 | Copyright (C) Daniel Fernandes Martins 242 | 243 | Distributed under the New BSD License. See COPYING for further details. 244 | -------------------------------------------------------------------------------- /src/zipper.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-zipper) 2 | 3 | (defstruct loc 4 | "A location consists of a distinguished tree, the current focus of attention 5 | and its path, representing its surrounding context." 6 | (left "Nodes on the left of this location.") 7 | (ppath "Path to this location from the root.") 8 | (right "Nodes on the right of this location.")) 9 | 10 | (defun zipper (lst) 11 | "Creates a zipper for the list lst." 12 | (list lst nil)) 13 | 14 | (defmacro with-loc (loc &body body) 15 | "Binds the variables 'loc-tree' and 'loc-path' for the tree and path of this 16 | loc, respectively." 17 | `(let ((loc-tree (car ,loc)) 18 | (loc-path (cadr ,loc))) 19 | loc-tree loc-path 20 | ,@body)) 21 | 22 | (defun root-node (loc) 23 | "Zips all the way up and returns the root node, reflecting any changes." 24 | (let ((loc-up (go-up loc))) 25 | (if loc-up 26 | (root-node loc-up) 27 | (car loc)))) 28 | 29 | (defun go-down (loc) 30 | "Returns the loc of the leftmost child of the node at this loc, or nil if no 31 | children." 32 | (with-loc loc 33 | (when (consp loc-tree) 34 | (list (car loc-tree) 35 | (make-loc :left nil 36 | :ppath loc-path 37 | :right (cdr loc-tree)))))) 38 | 39 | (defun go-right (loc) 40 | "Returns the loc of the right sibling of the node at this loc, or nil." 41 | (with-loc loc 42 | (when loc-path 43 | (let ((left (loc-left loc-path)) 44 | (right (loc-right loc-path))) 45 | (when right 46 | (list (car right) 47 | (make-loc :left (cons loc-tree left) 48 | :ppath (loc-ppath loc-path) 49 | :right (cdr right)))))))) 50 | 51 | (defun rights (loc) 52 | "Returns a list of the right siblings of this loc." 53 | (with-loc loc 54 | (when loc-path 55 | (loc-right loc-path)))) 56 | 57 | (defun rightmost (loc) 58 | "Returns the loc of the rightmost sibling of the node at this loc, or self." 59 | (with-loc loc 60 | (if loc-path 61 | (let ((right (loc-right loc-path))) 62 | (list (car (last right)) 63 | (make-loc :left (cons (car (butlast right)) (list loc-tree)) 64 | :ppath (loc-ppath loc-path) 65 | :right nil))) 66 | loc))) 67 | 68 | (defun go-left (loc) 69 | "Returns the loc of the left sibling of the node at this loc, or nil." 70 | (with-loc loc 71 | (when loc-path 72 | (let ((left (loc-left loc-path)) 73 | (right (loc-right loc-path))) 74 | (when left 75 | (list (car left) 76 | (make-loc :left (cdr left) 77 | :ppath (loc-ppath loc-path) 78 | :right (cons loc-tree right)))))))) 79 | 80 | (defun lefts (loc) 81 | "Returns a list of the left siblings of this loc." 82 | (with-loc loc 83 | (when loc-path 84 | (loc-left loc-path)))) 85 | 86 | (defun leftmost (loc) 87 | "Returns the loc of the leftmost sibling of the node at this loc, or self." 88 | (with-loc loc 89 | (if loc-path 90 | (let ((left (loc-left loc-path))) 91 | (list (car (last left)) 92 | (make-loc :left nil 93 | :ppath (loc-ppath loc-path) 94 | :right (cons (car (butlast left)) (list loc-tree))))) 95 | loc))) 96 | 97 | (defun go-up (loc) 98 | "Returns the loc of the parent node of the node at this loc, or nil if at 99 | the top." 100 | (with-loc loc 101 | (when loc-path 102 | (list (concatenate 'list (reverse (loc-left loc-path)) 103 | (when loc-tree 104 | (cons loc-tree (loc-right loc-path)))) 105 | (loc-ppath loc-path))))) 106 | 107 | (defun go-next (loc) 108 | "Moves to the next loc in the hierarchy, depth-first. When reaching the end, 109 | returns nil." 110 | (with-loc loc 111 | (or (and (consp loc-tree) (go-down loc)) 112 | (go-right loc) 113 | (go-next-up loc)))) 114 | 115 | (defun go-next-up (loc) 116 | "Moves up in hierarchy until a right node is found or the root is reached." 117 | (let ((uloc (go-up loc))) 118 | (when uloc 119 | (or (go-right uloc) (go-next-up uloc))))) 120 | 121 | (defun go-prev (loc) 122 | "Moves to the previous loc in the hierarchy, depth-first. If already at the 123 | root, returns nil." 124 | (let ((lloc (go-left loc))) 125 | (if lloc 126 | (go-prev-up lloc) 127 | (go-up loc)))) 128 | 129 | (defun go-prev-up (loc) 130 | "Moves up in the hierarchy until a left node is found or the root is reached." 131 | (with-loc loc 132 | (let ((dloc (and (consp loc-tree) (go-down loc)))) 133 | (if dloc 134 | (go-prev-up (rightmost dloc)) 135 | loc)))) 136 | 137 | (defun path (loc) 138 | "Returns the list of nodes leading to this loc." 139 | (let ((loc-up (go-up loc))) 140 | (when loc-up 141 | (append (path loc-up) (list (car loc-up)))))) 142 | 143 | (defun change-node (loc tree) 144 | "Replaces the node at this loc, whithout moving." 145 | (when loc 146 | (list tree (cadr loc)))) 147 | 148 | (defun edit-node (loc func &rest args) 149 | "Replaces the node at this loc with the value of (func node args)." 150 | (change-node loc (apply func (car loc) args))) 151 | 152 | (defun insert-right (loc tree) 153 | "Inserts the item as the right sibling of the node at this loc, without 154 | moving." 155 | (with-loc loc 156 | (when loc-path 157 | (list loc-tree 158 | (make-loc :left (loc-left loc-path) 159 | :ppath (loc-ppath loc-path) 160 | :right (cons tree (loc-right loc-path))))))) 161 | 162 | (defun insert-left (loc tree) 163 | "Inserts the item as the left sibling of the node at this loc, without 164 | moving." 165 | (with-loc loc 166 | (when loc-path 167 | (list loc-tree 168 | (make-loc :left (cons tree (loc-left loc-path)) 169 | :ppath (loc-ppath loc-path) 170 | :right (loc-right loc-path)))))) 171 | 172 | (defun insert-down (loc tree) 173 | "Inserts the item as the leftmost child of the node at this loc, without 174 | moving." 175 | (with-loc loc 176 | (when (consp loc-tree) 177 | (list (cons tree loc-tree) 178 | loc-path)))) 179 | 180 | (defun append-down (loc tree) 181 | "Inserts the item as the rightmost child of the node at this loc, without 182 | moving." 183 | (with-loc loc 184 | (when (consp loc-tree) 185 | (list (concatenate 'list loc-tree (list tree)) 186 | loc-path)))) 187 | 188 | (defun remove-node (loc) 189 | "Removes the node at loc, returning the loc that would have preceded it in a 190 | depth-first walk." 191 | (with-loc loc 192 | (when (and loc loc-path) 193 | (cond ((loc-right loc-path) (replace-by-right loc-path)) 194 | ((loc-left loc-path) (replace-by-left loc-path)))))) 195 | 196 | (defun replace-by-right (loc-path) 197 | "Replaces the current node at loc by the node at the right." 198 | (when loc-path 199 | (let ((right (loc-right loc-path))) 200 | (list (car right) 201 | (make-loc :left (loc-left loc-path) 202 | :ppath (loc-ppath loc-path) 203 | :right (cdr right)))))) 204 | 205 | (defun replace-by-left (loc-path) 206 | "Replaces the current node at loc by the node at the left." 207 | (when loc-path 208 | (let ((left (loc-left loc-path))) 209 | (list (car left) 210 | (make-loc :left (cdr left) 211 | :ppath (loc-ppath loc-path) 212 | :right (loc-right loc-path)))))) 213 | -------------------------------------------------------------------------------- /tests/zipper-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-zipper.tests) 2 | 3 | (in-suite :cl-zipper) 4 | 5 | (defparameter *tree* '(/ (+ (* a 2) (- b 4)))) 6 | 7 | (defun -> (tree &rest path) 8 | "Navigates the given path on tree, where each element in path is a keyword 9 | that represents the desired direction, i.e., :down, :up, :left, :right." 10 | (labels ((nav (loc rest) 11 | (if rest 12 | (nav (case (car rest) 13 | (:down (go-down loc)) 14 | (:up (go-up loc)) 15 | (:left (go-left loc)) 16 | (:right (go-right loc)) 17 | (otherwise loc)) 18 | (cdr rest)) 19 | loc))) 20 | (nav (zipper tree) path))) 21 | 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | ;;; ZIPPER 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | 27 | (test zipper 28 | (let ((loc (-> *tree*))) 29 | (is (equal 2 (length loc))) 30 | (is (equal *tree* (car loc))) 31 | (is (null (cadr loc))))) 32 | 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;;; ROOT-NODE 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (test root-node 39 | (let ((loc (root-node (-> *tree* :down :right :down :right :right)))) 40 | (is (equal 2 (length loc))) 41 | (is (equal *tree* loc)))) 42 | 43 | (test root-node-at-root 44 | (let ((loc (root-node (-> *tree*)))) 45 | (is (equal 2 (length loc))) 46 | (is (equal *tree* loc)))) 47 | 48 | (test root-node-at-nil 49 | (is (null (root-node nil)))) 50 | 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | ;;; GO-LEFT 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | 56 | (test go-left 57 | (let* ((loc (-> *tree* :down :right :down :right :right)) 58 | (new-loc-1 (go-left loc)) 59 | (new-loc-2 (go-left new-loc-1))) 60 | (is (equal '(* a 2) (car new-loc-1))) 61 | (is (equal '(+) (lefts new-loc-1))) 62 | (is (equal '((- b 4)) (rights new-loc-1))) 63 | 64 | (is (equal '+ (car new-loc-2))) 65 | (is (null (lefts new-loc-2))) 66 | (is (equal '((* a 2) (- b 4)) (rights new-loc-2))))) 67 | 68 | (test go-left-at-root 69 | (is (null (go-left (-> *tree*))))) 70 | 71 | (test go-left-at-nil 72 | (is (null (go-left nil)))) 73 | 74 | (test go-left-at-end 75 | (let ((loc (-> *tree* :down))) 76 | (is (equal '/ (car loc))) 77 | (is (null (lefts loc))) 78 | (is (null (go-left loc))))) 79 | 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;; GO-RIGHT 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | (test go-right 86 | (let* ((loc (-> *tree* :down :right :down)) 87 | (new-loc-1 (go-right loc)) 88 | (new-loc-2 (go-right new-loc-1))) 89 | (is (equal '(* a 2) (car new-loc-1))) 90 | (is (equal '(+) (lefts new-loc-1))) 91 | (is (equal '((- b 4)) (rights new-loc-1))) 92 | 93 | (is (equal '(- b 4) (car new-loc-2))) 94 | (is (equal '((* a 2) +) (lefts new-loc-2))) 95 | (is (null (rights new-loc-2))))) 96 | 97 | (test go-right-at-root 98 | (is (null (go-right (-> *tree*))))) 99 | 100 | (test go-right-at-nil 101 | (is (null (go-right nil)))) 102 | 103 | (test go-right-at-end 104 | (let ((loc (rightmost (-> *tree* :down :right :down)))) 105 | (is (equal '(- b 4) (car loc))) 106 | (is (null (rights loc))) 107 | (is (null (go-right loc))))) 108 | 109 | 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | ;;; GO-UP 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | 114 | (test go-up 115 | (let* ((loc (-> *tree* :down :right :down :right :down)) 116 | (new-loc-1 (go-up loc)) 117 | (new-loc-2 (go-up new-loc-1))) 118 | (is (equal '(* a 2) (car new-loc-1))) 119 | (is (equal '(+) (lefts new-loc-1))) 120 | (is (equal '((- b 4)) (rights new-loc-1))) 121 | 122 | (is (equal '(+ (* a 2) (- b 4)) (car new-loc-2))) 123 | (is (equal '(/) (lefts new-loc-2))) 124 | (is (null (rights new-loc-2))))) 125 | 126 | (test go-up-at-root 127 | (is (null (go-up (-> *tree*))))) 128 | 129 | (test go-up-at-nil 130 | (is (null (go-up nil)))) 131 | 132 | 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | ;;; GO-DOWN 135 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 136 | 137 | (test go-down 138 | (let* ((loc (-> *tree* :down :right)) 139 | (new-loc-1 (go-down loc)) 140 | (new-loc-2 (go-down (go-right new-loc-1)))) 141 | (is (equal '+ (car new-loc-1))) 142 | (is (null (lefts new-loc-1))) 143 | (is (equal '((* a 2) (- b 4)) (rights new-loc-1))) 144 | 145 | (is (equal '* (car new-loc-2))) 146 | (is (null (lefts new-loc-2))) 147 | (is (equal '(a 2) (rights new-loc-2))))) 148 | 149 | (test go-down-at-end 150 | (is (null (go-down (-> *tree* :down :right :down :right :down))))) 151 | 152 | (test go-down-at-nil 153 | (is (null (go-down nil)))) 154 | 155 | 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | ;;; LEFTMOST 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | 160 | (test leftmost 161 | (let ((loc (leftmost (-> *tree* :down :right :down :right :right)))) 162 | (is (equal '+ (car loc))) 163 | (is (null (lefts loc))) 164 | (is (equal '((* a 2) (- b 4)) (rights loc))))) 165 | 166 | (test leftmost-at-nil 167 | (is (null (leftmost nil)))) 168 | 169 | 170 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 | ;;; RIGHTMOST 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | 174 | (test rightmost 175 | (let ((loc (rightmost (-> *tree* :down :right :down)))) 176 | (is (equal '(- b 4) (car loc))) 177 | (is (null (rights loc))) 178 | (is (equal '((* a 2) +) (lefts loc))))) 179 | 180 | (test rightmost-at-nil 181 | (is (null (rightmost nil)))) 182 | 183 | 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | ;;; GO-NEXT 186 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 187 | 188 | (test go-next 189 | (let* ((loc (-> *tree* :down :right :down :right :down)) 190 | (next-loc (go-next loc))) 191 | (is (equal '* (car loc))) 192 | (is (equal 'a (car next-loc))) 193 | (is (equal '(*) (lefts next-loc))) 194 | (is (equal '(2) (rights next-loc))))) 195 | 196 | (test go-next-at-root 197 | (let* ((loc (-> *tree*)) 198 | (next-loc (go-next loc))) 199 | (is (equal *tree* (car loc))) 200 | (is (equal '/ (car next-loc))) 201 | (is (equal '() (lefts next-loc))) 202 | (is (equal '((+ (* a 2) (- b 4))) (rights next-loc))))) 203 | 204 | (test go-next-at-rightmost 205 | (let* ((loc (-> *tree* :down :right :down :right :down :right :right)) 206 | (next-loc (go-next loc))) 207 | (is (equal 2 (car loc))) 208 | (is (equal '(- b 4) (car next-loc))) 209 | (is (equal '((* a 2) +) (lefts next-loc))) 210 | (is (equal '() (rights next-loc))))) 211 | 212 | (test go-next-at-nested-rightmost 213 | (let* ((loc (-> '(+ (- 1 (* 2 3)) 4) :down :right :down :right :right :down :right :right)) 214 | (next-loc (go-next loc))) 215 | (is (equal 3 (car loc))) 216 | (is (equal 4 (car next-loc))) 217 | (is (equal '((- 1 (* 2 3)) +) (lefts next-loc))) 218 | (is (equal '() (rights next-loc))))) 219 | 220 | (test go-next-at-last 221 | (let* ((loc (-> *tree* :down :right :down :right :right :down :right :right)) 222 | (next-loc (go-next loc))) 223 | (is (equal 4 (car loc))) 224 | (is (null next-loc)))) 225 | 226 | 227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228 | ;;; GO-PREV 229 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 230 | 231 | (test go-prev 232 | (let* ((loc (-> *tree* :down :right :down :right :down :right)) 233 | (prev-loc (go-prev loc))) 234 | (is (equal 'a (car loc))) 235 | (is (equal '* (car prev-loc))) 236 | (is (equal '() (lefts prev-loc))) 237 | (is (equal '(a 2) (rights prev-loc))))) 238 | 239 | (test go-prev-at-root 240 | (let* ((loc (-> *tree*)) 241 | (prev-loc (go-prev loc))) 242 | (is (null prev-loc)))) 243 | 244 | (test go-prev-at-leftmost 245 | (let* ((loc (-> *tree* :down :right :down :right :down)) 246 | (prev-loc (go-prev loc))) 247 | (is (equal '* (car loc))) 248 | (is (equal '(* a 2) (car prev-loc))))) 249 | 250 | (test go-prev-at-rightmost 251 | (let* ((loc (-> *tree* :down :right :down :right :right)) 252 | (prev-loc (go-prev loc))) 253 | (is (equal '(- b 4) (car loc))) 254 | (is (equal 2 (car prev-loc))))) 255 | 256 | 257 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 258 | ;;; PATH 259 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 260 | 261 | (test path 262 | (let ((loc (-> *tree* :down :right :down :right :down))) 263 | (is (equal '((/ (+ (* a 2) (- b 4))) 264 | (+ (* a 2) (- b 4)) 265 | (* a 2)) (path loc))))) 266 | 267 | (test path-at-root 268 | (is (null (path (-> *tree*))))) 269 | 270 | (test path-at-nil 271 | (is (null (path nil)))) 272 | 273 | 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | ;;; CHANGE-NODE 276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | 278 | (test change-node-atom 279 | (let* ((loc (-> *tree* :down :right :down :right :down :right)) 280 | (new-loc (change-node loc 'x))) 281 | (is (equal 'a (car loc))) 282 | (is (equal 'x (car new-loc))) 283 | (is (equal '(*) (lefts new-loc))) 284 | (is (equal '(2) (rights new-loc))) 285 | (is (equal '(/ (+ (* x 2) (- b 4))) (root-node new-loc))))) 286 | 287 | (test change-node-subtree 288 | (let* ((loc (-> *tree* :down :right :down :right)) 289 | (new-loc (change-node loc '(+ a a)))) 290 | (is (equal '(* a 2) (car loc))) 291 | (is (equal '(+ a a) (car new-loc))) 292 | (is (equal '(+) (lefts new-loc))) 293 | (is (equal '((- b 4)) (rights new-loc))) 294 | (is (equal '(/ (+ (+ a a) (- b 4))) (root-node new-loc))))) 295 | 296 | (test change-node-null 297 | (is (null (change-node nil 'x)))) 298 | 299 | 300 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 301 | ;;; EDIT-NODE 302 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 303 | 304 | (test edit-node 305 | (labels ((fn (node arg-1 arg-2 &optional (arg-3 3)) 306 | (is (equal '(* a 2) node)) 307 | (is (equal 1 arg-1)) 308 | (is (equal 2 arg-2)) 309 | (is (equal 3 arg-3)) 310 | '(- b))) 311 | (let* ((loc (-> *tree* :down :right :down :right)) 312 | (new-loc (edit-node loc #'fn 1 2))) 313 | (is (equal '(* a 2) (car loc))) 314 | (is (equal '(- b) (car new-loc))) 315 | (is (equal '(+) (lefts new-loc))) 316 | (is (equal '((- b 4)) (rights new-loc))) 317 | (is (equal '(/ (+ (- b) (- b 4))) (root-node new-loc)))))) 318 | 319 | (test edit-node-null 320 | (is (null (edit-node nil #'identity)))) 321 | 322 | 323 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 324 | ;;; INSERT-DOWN 325 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 326 | 327 | (test insert-down 328 | (let* ((loc (-> *tree* :down :right :down :right)) 329 | (new-loc (insert-down loc '-))) 330 | (is (equal '(* a 2) (car loc))) 331 | (is (equal '(- * a 2) (car new-loc))) 332 | (is (equal '(+) (lefts new-loc))) 333 | (is (equal '((- b 4)) (rights new-loc))) 334 | (is (equal '(/ (+ (- * a 2) (- b 4))) (root-node new-loc))))) 335 | 336 | (test insert-down-at-atom 337 | (let ((loc (-> *tree* :down :right :down :right :down))) 338 | (is (null (insert-down loc '-))))) 339 | 340 | (test insert-down-at-nil 341 | (is (null (insert-down nil '-)))) 342 | 343 | 344 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 345 | ;;; APPEND-DOWN 346 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 347 | 348 | (test append-down 349 | (let* ((loc (-> *tree* :down :right :down :right)) 350 | (new-loc (append-down loc 'b))) 351 | (is (equal '(* a 2) (car loc))) 352 | (is (equal '(* a 2 b) (car new-loc))) 353 | (is (equal '(+) (lefts new-loc))) 354 | (is (equal '((- b 4)) (rights new-loc))) 355 | (is (equal '(/ (+ (* a 2 b) (- b 4))) (root-node new-loc))))) 356 | 357 | (test append-down-at-atom 358 | (let ((loc (-> *tree* :down :right :down :right :down))) 359 | (is (null (append-down loc 'b))))) 360 | 361 | (test append-down-at-nil 362 | (is (null (append-down nil 'b)))) 363 | 364 | 365 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 366 | ;;; INSERT-LEFT 367 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 368 | 369 | (test insert-left 370 | (let* ((loc (-> *tree* :down :right :down :right :down :right)) 371 | (new-loc (insert-left loc 'b))) 372 | (is (equal 'a (car new-loc))) 373 | (is (equal '(*) (lefts loc))) 374 | (is (equal '(b *) (lefts new-loc))) 375 | (is (equal '(/ (+ (* b a 2) (- b 4))) (root-node new-loc))))) 376 | 377 | (test insert-left-at-nil 378 | (is (null (insert-left nil 'b)))) 379 | 380 | 381 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 382 | ;;; INSERT-RIGHT 383 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 384 | 385 | (test insert-right 386 | (let* ((loc (-> *tree* :down :right :down :right :down :right)) 387 | (new-loc (insert-right loc 'b))) 388 | (is (equal 'a (car new-loc))) 389 | (is (equal '(2) (rights loc))) 390 | (is (equal '(b 2) (rights new-loc))) 391 | (is (equal '(/ (+ (* a b 2) (- b 4))) (root-node new-loc))))) 392 | 393 | (test insert-right-at-nil 394 | (is (null (insert-right nil 'b)))) 395 | 396 | 397 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 398 | ;;; REMOVE-NODE 399 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 400 | 401 | (test remove-node 402 | (let* ((loc (-> *tree* :down :right :down :right :down :right)) 403 | (new-loc (remove-node loc))) 404 | (is (equal 'a (car loc))) 405 | (is (equal '2 (car new-loc))) 406 | (is (equal '(*) (lefts new-loc))) 407 | (is (null (rights new-loc))) 408 | (is (equal '(/ (+ (* 2) (- b 4))) (root-node new-loc))))) 409 | 410 | (test remove-node-at-leftmost-node 411 | (let* ((loc (-> *tree* :down :right :down :right :down)) 412 | (new-loc (remove-node loc))) 413 | (is (equal '* (car loc))) 414 | (is (equal 'a (car new-loc))) 415 | (is (null (lefts new-loc))) 416 | (is (equal '(2) (rights new-loc))) 417 | (is (equal '(/ (+ (a 2) (- b 4))) (root-node new-loc))))) 418 | 419 | (test remove-node-at-rightmost-node 420 | (let* ((loc (rightmost (-> *tree* :down :right :down :right :down))) 421 | (new-loc (remove-node loc))) 422 | (is (equal '2 (car loc))) 423 | (is (equal 'a (car new-loc))) 424 | (is (equal '(*) (lefts new-loc))) 425 | (is (null (rights new-loc))) 426 | (is (equal '(/ (+ (* a) (- b 4))) (root-node new-loc))))) 427 | 428 | (test remove-node-at-nil 429 | (is (null (remove-node nil)))) --------------------------------------------------------------------------------