.emacs.d.git - Gitblit

Chizi123

2018-11-18 8f6f2705a38e2515b6c57fda12c5be29fb9a798f

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