treepy.el (17871B)
1 ;;; treepy.el --- Generic tree traversal tools -*- lexical-binding: t -*- 2 ;; 3 ;; Filename: treepy.el 4 ;; 5 ;; Copyright (C) 2017 Daniel Barreto 6 ;; 7 ;; Description: Generic Tree Traversing Tools 8 ;; Author: Daniel Barreto <daniel.barreto.n@gmail.com> 9 ;; Keywords: lisp, maint, tools 10 ;; Package-Version: 0.1.2 11 ;; Package-Commit: 3ac940e97f3d03e48ca9d7fcd74916a9b01c72f3 12 ;; Created: Mon Jul 10 15:17:36 2017 (+0200) 13 ;; Version: 0.1.1 14 ;; Package-Requires: ((emacs "25.1")) 15 ;; URL: https://github.com/volrath/treepy.el 16 ;; 17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 ;; 19 ;;; Commentary: 20 ;; 21 ;; Generic tools for recursive and iterative tree traversal based on 22 ;; clojure.walk and clojure.zip respectively. Depends on `map', a map 23 ;; manipulation library built in Emacs 25.1. All functions are prefixed 24 ;; with "treepy-" 25 ;; 26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;; 28 ;; This program is free software: you can redistribute it and/or modify 29 ;; it under the terms of the GNU General Public License as published by 30 ;; the Free Software Foundation, either version 3 of the License, or (at 31 ;; your option) any later version. 32 ;; 33 ;; This program is distributed in the hope that it will be useful, but 34 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 36 ;; General Public License for more details. 37 ;; 38 ;; You should have received a copy of the GNU General Public License 39 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. 40 ;; 41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 ;; 43 ;;; Code: 44 45 (require 'map) 46 (require 'cl-lib) 47 48 ;;; Walk (recursive tree traversal) 49 50 (defun treepy-walk (inner outer form) 51 "Using INNER and OUTER, traverse FORM, an arbitrary data structure. 52 INNER and OUTER are functions. Apply INNER to each element of 53 FORM, building up a data structure of the same type, then apply 54 OUTER to the result. Recognize cons, lists, alists, vectors and 55 hash tables." 56 (cond 57 ((and (listp form) (cdr form) (atom (cdr form))) (funcall outer (cons (funcall inner (car form)) 58 (funcall inner (cdr form))))) 59 ((listp form) (funcall outer (mapcar inner form))) 60 ((vectorp form) (funcall outer (apply #'vector (mapcar inner form)))) 61 ((hash-table-p form) (funcall outer (map-apply (lambda (k v) (funcall inner (cons k v))) form))) 62 (t (funcall outer form)))) 63 64 (defun treepy-postwalk (f form) 65 "Perform a depth-first, post-order traversal of F applied to FORM. 66 Call F on each sub-form, use F's return value in place of the 67 original. Recognize cons, lists, alists, vectors and 68 hash tables." 69 (treepy-walk (apply-partially #'treepy-postwalk f) f form)) 70 71 (defun treepy-prewalk (f form) 72 "Perform a depth-first, pre-order traversal of F applied to FORM. 73 Like `treepy-postwalk'." 74 (treepy-walk (apply-partially #'treepy-prewalk f) #'identity (funcall f form))) 75 76 (defun treepy-postwalk-demo (form) 77 "Demonstrate the behavior of `treepy-postwalk' for FORM. 78 Return a list of each form as it is walked." 79 (let ((walk nil)) 80 (treepy-postwalk (lambda (x) (push x walk) x) 81 form) 82 (reverse walk))) 83 84 (defun treepy-prewalk-demo (form) 85 "Demonstrate the behavior of `treepy-prewalk' for FORM. 86 Return a list of each form as it is walked." 87 (let ((walk nil)) 88 (treepy-prewalk (lambda (x) (push x walk) x) 89 form) 90 (reverse walk))) 91 92 (defun treepy-postwalk-replace (smap form &optional testfn) 93 "Use SMAP to transform FORM by doing replacing operations. 94 Recursively replace in FORM keys in SMAP with their values. Does 95 replacement at the leaves of the tree first. The optional TESTFN 96 parameter is the function to be used by `map-contains-key'." 97 (treepy-postwalk (lambda (x) (if (map-contains-key smap x testfn) (map-elt smap x) x)) 98 form)) 99 100 (defun treepy-prewalk-replace (smap form &optional testfn) 101 "Use SMAP to transform FORM by doing replacing operations. 102 Recursively replace in FORM keys in SMAP with their values. Does 103 replacement at the root of the tree first. The optional TESTFN 104 parameter is the function to be used by `map-contains-key'." 105 (treepy-prewalk (lambda (x) (if (map-contains-key smap x testfn) (map-elt smap x) x)) 106 form)) 107 108 109 ;;; Zipper (iterative tree traversal) 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 112 (defun treepy--context (loc &optional key) 113 "Return context for this LOC. 114 If KEY is given, only return this key's value in context." 115 (let ((context (cdr (car loc)))) 116 (if (and context key) 117 (map-elt context key) 118 context))) 119 120 (defun treepy--context-assoc-1 (context k v) 121 "Assoc in CONTEXT a key K with a value V." 122 (if (map-contains-key context k) 123 (mapcar (lambda (entry) 124 (if (equal (car entry) k) 125 (cons k v) 126 entry)) 127 context) 128 (cons (cons k v) context))) 129 130 (defun treepy--context-assoc (context &rest kvs) 131 "Immutable map association in CONTEXT using KVS." 132 (seq-reduce (lambda (context kv) 133 (seq-let [k v] kv 134 (treepy--context-assoc-1 context k v))) 135 (seq-partition kvs 2) context)) 136 137 (defun treepy--meta (loc &optional key) 138 "Return meta information for this LOC. 139 If KEY is given, only return this key's value in meta 140 information." 141 (let ((meta (cdr loc))) 142 (if key 143 (map-elt meta key) 144 meta))) 145 146 (defun treepy--with-meta (obj meta) 147 "Bind OBJ with some META information." 148 (cons obj meta)) 149 150 (defun treepy--join-children (left-children right-children) 151 "Return a joining of LEFT-CHILDREN and RIGHT-CHILDREN. 152 Reverses LEFT-CHILDREN so that they are correctly ordered as in 153 the tree." 154 (append (reverse left-children) right-children)) 155 156 (defmacro treepy--with-loc (loc vars &rest body) 157 "Create a lexical context using LOC VARS. 158 Execute BODY in this context." 159 (declare (indent defun)) 160 (let ((lex-ctx (mapcar (lambda (v) 161 (cl-case v 162 ('node `(node (treepy-node ,loc))) 163 ('context `(context (treepy--context ,loc))) 164 (t `(,v (treepy--context ,loc (quote ,(intern (concat ":" (symbol-name v))))))))) 165 vars))) 166 `(let* (,@lex-ctx) ,@body))) 167 168 ;;;; Construction 169 170 (defun treepy-zipper (branchp children make-node root) 171 "Create a new zipper structure. 172 173 BRANCHP is a function that, given a node, returns t if it can 174 have children, even if it currently doesn't. 175 176 CHILDREN is a function that, given a branch node, returns a seq 177 of its children. 178 179 MAKE-NODE is a function that, given an existing node and a seq of 180 children, returns a new branch node with the supplied children. 181 182 ROOT is the root node." 183 (treepy--with-meta 184 (cons root nil) 185 `((:branchp . ,branchp) (:children . ,children) (:make-node . ,make-node)))) 186 187 (defun treepy-list-zip (root) 188 "Return a zipper for nested lists, given a ROOT list." 189 (let ((make-node (lambda (_ children) children))) 190 (treepy-zipper #'listp #'identity make-node root))) 191 192 (defun treepy-vector-zip (root) 193 "Return a zipper for nested vectors, given a ROOT vector." 194 (let ((make-node (lambda (_ children) (apply #'vector children))) 195 (children (lambda (cs) (seq-into cs 'list)))) 196 (treepy-zipper #'vectorp children make-node root))) 197 198 ;;;; Context 199 200 (defun treepy-node (loc) 201 "Return the node at LOC." 202 (caar loc)) 203 204 (defun treepy-branch-p (loc) 205 "Return t if the node at LOC is a branch." 206 (funcall (treepy--meta loc ':branchp) (treepy-node loc))) 207 208 (defun treepy-children (loc) 209 "Return a children list of the node at LOC, which must be a branch." 210 (if (treepy-branch-p loc) 211 (funcall (treepy--meta loc ':children) (treepy-node loc)) 212 (error "Called children on a leaf node"))) 213 214 (defun treepy-make-node (loc node children) 215 "Return a new branch node. 216 Given an existing LOC, NODE and new CHILDREN, creates a new LOC 217 with them. The LOC is only used to supply the constructor." 218 (funcall (treepy--meta loc ':make-node) node children)) 219 220 (defun treepy-path (loc) 221 "Return a list of nodes leading to the given LOC." 222 (reverse (treepy--context loc ':pnodes))) 223 224 (defun treepy-lefts (loc) 225 "Return a list of the left siblings of this LOC." 226 (reverse (treepy--context loc ':l))) 227 228 (defun treepy-rights (loc) 229 "Return a list of the right siblings of this LOC." 230 (treepy--context loc ':r)) 231 232 ;;;; Navigation 233 234 (defun treepy-down (loc) 235 "Return the loc of the leftmost child of the node at this LOC. 236 nil if no children." 237 (when (treepy-branch-p loc) 238 (let ((children (treepy-children loc))) 239 (treepy--with-loc loc (node context pnodes) 240 (seq-let [c &rest cs] children 241 (when children 242 (treepy--with-meta 243 `(,c . ((:l . ,nil) 244 (:pnodes . ,(if context (cons node pnodes) (list node))) 245 (:ppath . ,context) 246 (:r . ,cs))) 247 (treepy--meta loc)))))))) 248 249 (defun treepy-up (loc) 250 "Return the loc of the parent of the node at this LOC. 251 nil if at the top." 252 (treepy--with-loc loc (node pnodes ppath changed? l r) 253 (when pnodes 254 (let ((pnode (car pnodes))) 255 (treepy--with-meta 256 (if changed? 257 (cons (treepy-make-node loc pnode (treepy--join-children l (cons node r))) 258 (and ppath (treepy--context-assoc ppath ':changed? t))) 259 (cons pnode ppath)) 260 (treepy--meta loc)))))) 261 262 (defun treepy-root (loc) 263 "Zip from LOC all the way up and return the root node. 264 Reflect any alterations to the tree." 265 (if (equal :end (treepy--context loc)) 266 (treepy-node loc) 267 (let ((p loc)) 268 (while (setq p (treepy-up p)) 269 (setq loc p)) 270 (treepy-node loc)))) 271 272 (defun treepy-right (loc) 273 "Return the loc of the right sibling of the node at this LOC. 274 nil if there's no more right sibilings." 275 (treepy--with-loc loc (node context l r) 276 (let ((r (if (listp r) 277 r 278 ;; If `r' is not a list (or nil), then we're dealing with a non 279 ;; nil cdr ending list. 280 (cons r nil)))) 281 (seq-let [cr &rest rnext] r 282 (when (and context r) 283 (treepy--with-meta 284 (cons cr 285 (treepy--context-assoc context 286 ':l (cons node l) 287 ':r rnext)) 288 (treepy--meta loc))))))) 289 290 291 (defun treepy-rightmost (loc) 292 "Return the loc of the rightmost sibling of the node at this LOC. 293 If LOC is already the rightmost sibling, return self." 294 (treepy--with-loc loc (node context l r) 295 (if (and context r) 296 (treepy--with-meta 297 (cons (car (last r)) 298 (treepy--context-assoc context 299 ':l (treepy--join-children l (cons node (butlast r))) 300 ':r nil)) 301 (treepy--meta loc)) 302 loc))) 303 304 (defun treepy-left (loc) 305 "Return the loc of the left sibling of the node at this LOC. 306 nil if no more left sibilings." 307 (treepy--with-loc loc (node context l r) 308 (when (and context l) 309 (seq-let [cl &rest lnext] l 310 (treepy--with-meta 311 (cons cl 312 (treepy--context-assoc context 313 ':l lnext 314 ':r (cons node r))) 315 (treepy--meta loc)))))) 316 317 (defun treepy-leftmost (loc) 318 "Return the loc of the leftmost sibling of the node at this LOC. 319 If LOC is already the leftmost sibling, return self." 320 (treepy--with-loc loc (node context l r) 321 (if (and context l) 322 (treepy--with-meta 323 (cons (car (last l)) 324 (treepy--context-assoc context 325 ':l [] 326 ':r (treepy--join-children (butlast l) (cons node r)))) 327 (treepy--meta loc)) 328 loc))) 329 330 (defun treepy-leftmost-descendant (loc) 331 "Return the leftmost descendant of the given LOC. 332 \(ie, down repeatedly)." 333 (while (treepy-branch-p loc) 334 (setq loc (treepy-down loc))) 335 loc) 336 337 ;;;; Modification 338 339 (defun treepy-insert-left (loc item) 340 "Insert as the left sibling of this LOC'S node the ITEM. 341 Return same loc with sibilings updated." 342 (treepy--with-loc loc (node context l) 343 (if (not context) 344 (error "Insert at top") 345 (treepy--with-meta 346 (cons node 347 (treepy--context-assoc context 348 ':l (cons item l) 349 ':changed? t)) 350 (treepy--meta loc))))) 351 352 (defun treepy-insert-right (loc item) 353 "Insert as the right sibling of this LOC's node the ITEM. 354 Return same loc with sibilings updated." 355 (treepy--with-loc loc (node context r) 356 (if (not context) 357 (error "Insert at top") 358 (treepy--with-meta 359 (cons node 360 (treepy--context-assoc context 361 ':r (cons item r) 362 ':changed? t)) 363 (treepy--meta loc))))) 364 365 (defun treepy-replace (loc node) 366 "Replace the node in this LOC with the given NODE, without moving." 367 (let ((context (treepy--context loc))) 368 (treepy--with-meta 369 (cons node 370 (treepy--context-assoc context 371 ':changed? t)) 372 (treepy--meta loc)))) 373 374 (defun treepy-edit (loc f &rest args) 375 "Replace the node at this LOC with the value of (F node ARGS)." 376 (treepy-replace loc (apply f (treepy-node loc) args))) 377 378 (defun treepy-insert-child (loc item) 379 "Insert as the leftmost child of this LOC's node the ITEM. 380 Return same loc with children updated." 381 (treepy-replace loc (treepy-make-node loc (treepy-node loc) (cons item (treepy-children loc))))) 382 383 (defun treepy-append-child (loc item) 384 "Insert as the rightmost child of this LOC'S node the ITEM. 385 Return same loc with children updated." 386 (treepy-replace loc (treepy-make-node loc (treepy-node loc) (append (treepy-children loc) `(,item))))) ;; TODO: check performance 387 388 (defun treepy-remove (loc) 389 "Remove the node at LOC. 390 Return the loc that would have preceded it in a depth-first 391 walk." 392 (treepy--with-loc loc (context pnodes ppath l r) 393 (if (not context) 394 (error "Remove at top") 395 (if (> (length l) 0) 396 (let ((nloc (treepy--with-meta (cons (car l) 397 (treepy--context-assoc context 398 ':l (cdr l) 399 ':changed? t)) 400 (treepy--meta loc))) 401 (child nil)) 402 (while (setq child (and (treepy-branch-p nloc) (treepy-children nloc))) 403 (setq nloc (treepy-rightmost child))) 404 nloc) 405 (treepy--with-meta 406 (cons (treepy-make-node loc (car pnodes) r) 407 (and ppath (treepy--context-assoc context ':changed? t))) 408 (treepy--meta loc)))))) 409 410 ;;;; Enumeration 411 412 (defun treepy--preorder-next (loc) 413 "Move to the next LOC in the hierarchy, depth-first in preorder. 414 When reaching the end, returns a distinguished loc detectable via 415 `treepy-end-p'. If already at the end, stays there." 416 (if (equal :end (treepy--context loc)) 417 loc 418 (let ((cloc loc)) 419 (or 420 (and (treepy-branch-p cloc) (treepy-down cloc)) 421 (treepy-right cloc) 422 (let ((p cloc) 423 (pr nil)) 424 (while (and (treepy-up p) (not (setq pr (treepy-right (treepy-up p))))) 425 (setq p (treepy-up p))) 426 (or pr (cons (cons (treepy-node p) :end) nil))))))) 427 428 (defun treepy--postorder-next (loc) 429 "Move to the next LOC in the hierarchy, depth-first in postorder. 430 When reaching the end, returns a distinguished loc detectable via 431 `treepy-end-p'. If already at the end, stays there." 432 (if (equal :end (treepy--context loc)) 433 loc 434 (if (null (treepy-up loc)) 435 (cons (cons (treepy-node loc) :end) nil) 436 (or (let ((rloc (treepy-right loc))) 437 (and rloc (treepy-leftmost-descendant rloc))) 438 (treepy-up loc))))) 439 440 (defun treepy-next (loc &optional order) 441 "Move to the next LOC in the hierarchy, depth-first. 442 Use ORDER if given. Possible values for ORDER are `:preorder' and 443 `:postorder', defaults to the former." 444 (cl-case (or order ':preorder) 445 (':preorder (treepy--preorder-next loc)) 446 (':postorder (treepy--postorder-next loc)) 447 (t (error "Unrecognized order")))) 448 449 (defun treepy--preorder-prev (loc) 450 "Move to the previous LOC in the hierarchy, depth-first preorder. 451 If already at the root, returns nil." 452 (let ((lloc (treepy-left loc)) 453 (child nil)) 454 (if lloc 455 (progn 456 (while (setq child (and (treepy-branch-p lloc) (treepy-children lloc))) 457 (setq lloc (treepy-rightmost child))) 458 lloc) 459 (treepy-up loc)))) 460 461 (defun treepy--postorder-prev (loc) 462 "Move to the previous LOC in the hierarchy, depth-first postorder. 463 If already at the root, returns nil." 464 (if (treepy-branch-p loc) 465 (treepy-rightmost (treepy-down loc)) 466 (progn 467 (while (not (treepy-left loc)) 468 (setq loc (treepy-up loc))) 469 (treepy-left loc)))) 470 471 (defun treepy-prev (loc &optional order) 472 "Move to the previous LOC in the hierarchy, depth-first. 473 Use ORDER if given. Possible values for ORDER are `:preorder' and `:postorder', 474 defaults to the former." 475 (cl-case (or order ':preorder) 476 (':preorder (treepy--preorder-prev loc)) 477 (':postorder (treepy--postorder-prev loc)) 478 (t (error "Unrecognized order")))) 479 480 (defun treepy-end-p (loc) 481 "Return t if LOC represents the end of a depth-first walk." 482 (equal :end (treepy--context loc))) 483 484 (provide 'treepy) 485 486 ;;; treepy.el ends here