mirror of https://github.com/Chizi123/.emacs.d.git

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