1 ;;; undo-tree.el --- Treat undo history as a tree
4 ;; Copyright (C) 2009-2012 Free Software Foundation, Inc
6 ;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
8 ;; Keywords: convenience, files, undo, redo, history, tree
9 ;; URL: http://www.dr-qubit.org/emacs.php
10 ;; Git Repository: http://www.dr-qubit.org/git/undo-tree.git
12 ;; This file is part of Emacs.
14 ;; This file is free software: you can redistribute it and/or modify it under
15 ;; the terms of the GNU General Public License as published by the Free
16 ;; Software Foundation, either version 3 of the License, or (at your option)
19 ;; This program is distributed in the hope that it will be useful, but WITHOUT
20 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
21 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
24 ;; You should have received a copy of the GNU General Public License along
25 ;; with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
30 ;; Emacs has a powerful undo system. Unlike the standard undo/redo system in
31 ;; most software, it allows you to recover *any* past state of a buffer
32 ;; (whereas the standard undo/redo system can lose past states as soon as you
33 ;; redo). However, this power comes at a price: many people find Emacs' undo
34 ;; system confusing and difficult to use, spawning a number of packages that
35 ;; replace it with the less powerful but more intuitive undo/redo system.
37 ;; Both the loss of data with standard undo/redo, and the confusion of Emacs'
38 ;; undo, stem from trying to treat undo history as a linear sequence of
39 ;; changes. It's not. The `undo-tree-mode' provided by this package replaces
40 ;; Emacs' undo system with a system that treats undo history as what it is: a
41 ;; branching tree of changes. This simple idea allows the more intuitive
42 ;; behaviour of the standard undo/redo system to be combined with the power of
43 ;; never losing any history. An added side bonus is that undo history can in
44 ;; some cases be stored more efficiently, allowing more changes to accumulate
45 ;; before Emacs starts discarding history.
47 ;; The only downside to this more advanced yet simpler undo system is that it
48 ;; was inspired by Vim. But, after all, most successful religions steal the
49 ;; best ideas from their competitors!
55 ;; This package has only been tested with Emacs versions 22, 23 and CVS. It
56 ;; will not work without modifications in earlier versions of Emacs.
58 ;; To install `undo-tree-mode', make sure this file is saved in a directory in
59 ;; your `load-path', and add the line:
61 ;; (require 'undo-tree)
63 ;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using
64 ;; "M-x byte-compile-file" from within emacs).
66 ;; If you want to replace the standard Emacs' undo system with the
67 ;; `undo-tree-mode' system in all buffers, you can enable it globally by
70 ;; (global-undo-tree-mode)
72 ;; to your .emacs file.
78 ;; If you're the kind of person who likes to jump in the car and drive,
79 ;; without bothering to first figure out whether the button on the left dips
80 ;; the headlights or operates the ejector seat (after all, you'll soon figure
81 ;; it out when you push it), then here's the minimum you need to know:
83 ;; `undo-tree-mode' and `global-undo-tree-mode'
84 ;; Enable undo-tree mode (either in the current buffer or globally).
86 ;; C-_ C-/ (`undo-tree-undo')
89 ;; M-_ C-? (`undo-tree-redo')
92 ;; `undo-tree-switch-branch'
93 ;; Switch undo-tree branch.
94 ;; (What does this mean? Better press the button and see!)
96 ;; C-x u (`undo-tree-visualize')
97 ;; Visualize the undo tree.
98 ;; (Better try pressing this button too!)
100 ;; C-x r u (`undo-tree-save-state-to-register')
101 ;; Save current buffer state to register.
103 ;; C-x r U (`undo-tree-restore-state-from-register')
104 ;; Restore buffer state from register.
107 ;; In the undo-tree visualizer:
109 ;; <up> p C-p (`undo-tree-visualize-undo')
112 ;; <down> n C-n (`undo-tree-visualize-redo')
115 ;; <left> b C-b (`undo-tree-visualize-switch-branch-left')
116 ;; Switch to previous undo-tree branch.
118 ;; <right> f C-f (`undo-tree-visualize-switch-branch-right')
119 ;; Switch to next undo-tree branch.
121 ;; t (`undo-tree-visualizer-toggle-timestamps')
122 ;; Toggle display of time-stamps.
124 ;; q C-q (`undo-tree-visualizer-quit')
125 ;; Quit undo-tree-visualizer.
144 ;; To understand the different undo systems, it's easiest to consider an
145 ;; example. Imagine you make a few edits in a buffer. As you edit, you
146 ;; accumulate a history of changes, which we might visualize as a string of
147 ;; past buffer states, growing downwards:
149 ;; o (initial buffer state)
158 ;; x (current buffer state)
161 ;; Now imagine that you undo the last two changes. We can visualize this as
162 ;; rewinding the current state back two steps:
164 ;; o (initial buffer state)
167 ;; x (current buffer state)
176 ;; However, this isn't a good representation of what Emacs' undo system
177 ;; does. Instead, it treats the undos as *new* changes to the buffer, and adds
178 ;; them to the history:
180 ;; o (initial buffer state)
189 ;; x (buffer state before undo)
198 ;; Actually, since the buffer returns to a previous state after an undo,
199 ;; perhaps a better way to visualize it is to imagine the string of changes
200 ;; turning back on itself:
202 ;; (initial buffer state) o
205 ;; (first edit) o x (second undo)
208 ;; (second edit) o o (first undo)
211 ;; o (buffer state before undo)
213 ;; Treating undos as new changes might seem a strange thing to do. But the
214 ;; advantage becomes clear as soon as we imagine what happens when you edit
215 ;; the buffer again. Since you've undone a couple of changes, new edits will
216 ;; branch off from the buffer state that you've rewound to. Conceptually, it
219 ;; o (initial buffer state)
230 ;; The standard undo/redo system only lets you go backwards and forwards
231 ;; linearly. So as soon as you make that new edit, it discards the old
232 ;; branch. Emacs' undo just keeps adding changes to the end of the string. So
233 ;; the undo history in the two systems now looks like this:
235 ;; Undo/Redo: Emacs' undo
243 ;; . x (new edit) o o |
244 ;; (discarded . | / |
251 ;; Now, what if you change your mind about those undos, and decide you did
252 ;; like those other changes you'd made after all? With the standard undo/redo
253 ;; system, you're lost. There's no way to recover them, because that branch
254 ;; was discarded when you made the new edit.
256 ;; However, in Emacs' undo system, those old buffer states are still there in
257 ;; the undo history. You just have to rewind back through the new edit, and
258 ;; back through the changes made by the undos, until you reach them. Of
259 ;; course, since Emacs treats undos (even undos of undos!) as new changes,
260 ;; you're really weaving backwards and forwards through the history, all the
261 ;; time adding new changes to the end of the string as you go:
266 ;; o o o (undo new edit)
269 ;; o o | | o (undo the undo)
272 ;; (trying to get o | | x (undo the undo)
273 ;; to this state) | /
277 ;; So far, this is still reasonably intuitive to use. It doesn't behave so
278 ;; differently to standard undo/redo, except that by going back far enough you
279 ;; can access changes that would be lost in standard undo/redo.
281 ;; However, imagine that after undoing as just described, you decide you
282 ;; actually want to rewind right back to the initial state. If you're lucky,
283 ;; and haven't invoked any command since the last undo, you can just keep on
284 ;; undoing until you get back to the start:
286 ;; (trying to get o x (got there!)
287 ;; to this state) | |
289 ;; o o o o (keep undoing)
292 ;; o o | | o o (keep undoing)
295 ;; (already undid o | | o (got this far)
296 ;; to this state) | /
300 ;; But if you're unlucky, and you happen to have moved the point (say) after
301 ;; getting to the state labelled "got this far", then you've "broken the undo
302 ;; chain". Hold on to something solid, because things are about to get
303 ;; hairy. If you try to undo now, Emacs thinks you're trying to undo the
304 ;; undos! So to get back to the initial state you now have to rewind through
305 ;; *all* the changes, including the undos you just did:
307 ;; (trying to get o x (finally got there!)
308 ;; to this state) | |
312 ;; | | \ | \ | \ | \ |
313 ;; o o | | o o o | o o
314 ;; | / | | | / | | | /
316 ;; (already undid o | | o<. | | o
317 ;; to this state) | / : | /
321 ;; (got this far, but
322 ;; broke the undo chain)
326 ;; In practice you can just hold down the undo key until you reach the buffer
327 ;; state that you want. But whatever you do, don't move around in the buffer
328 ;; to *check* that you've got back to where you want! Because you'll break the
329 ;; undo chain, and then you'll have to traverse the entire string of undos
330 ;; again, just to get back to the point at which you broke the
331 ;; chain. Undo-in-region and commands such as `undo-only' help to make using
332 ;; Emacs' undo a little easier, but nonetheless it remains confusing for many
336 ;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent
337 ;; the history we've been discussing (make a few edits, undo a couple of them,
338 ;; and edit again)? The diagram that conceptually represented our undo
339 ;; history, before we started discussing specific undo systems? It looked like
342 ;; o (initial buffer state)
348 ;; o x (current state)
353 ;; Well, that's *exactly* what the undo history looks like to
354 ;; `undo-tree-mode'. It doesn't discard the old branch (as standard undo/redo
355 ;; does), nor does it treat undos as new changes to be added to the end of a
356 ;; linear string of buffer states (as Emacs' undo does). It just keeps track
357 ;; of the tree of branching changes that make up the entire undo history.
359 ;; If you undo from this point, you'll rewind back up the tree to the previous
373 ;; If you were to undo again, you'd rewind back to the initial state. If on
374 ;; the other hand you redo the change, you'll end up back at the bottom of the
375 ;; most recent branch:
377 ;; o (undo takes you here)
383 ;; o x (redo takes you here)
388 ;; So far, this is just like the standard undo/redo system. But what if you
389 ;; want to return to a buffer state located on a previous branch of the
390 ;; history? Since `undo-tree-mode' keeps the entire history, you simply need
391 ;; to tell it to switch to a different branch, and then redo the changes you
397 ;; o (start here, but switch
398 ;; |\ to the other branch)
405 ;; Now you're on the other branch, if you undo and redo changes you'll stay on
406 ;; that branch, moving up and down through the buffer states located on that
407 ;; branch. Until you decide to switch branches again, of course.
409 ;; Real undo trees might have multiple branches and sub-branches:
422 ;; Trying to imagine what Emacs' undo would do as you move about such a tree
423 ;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're
424 ;; just moving around this undo history tree. Most of the time, you'll
425 ;; probably only need to stay on the most recent branch, in which case it
426 ;; behaves like standard undo/redo, and is just as simple to understand. But
427 ;; if you ever need to recover a buffer state on a different branch, the
428 ;; possibility of switching between branches and accessing the full undo
429 ;; history is still there.
433 ;; The Undo-Tree Visualizer
434 ;; ========================
436 ;; Actually, it gets better. You don't have to imagine all these tree
437 ;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which
438 ;; draws them for you! In fact, it draws even better diagrams: it highlights
439 ;; the node representing the current buffer state, it highlights the current
440 ;; branch, and (by hitting "t") you can toggle the display of
441 ;; time-stamps. (There's one other tiny difference: the visualizer puts the
442 ;; most recent branch on the left rather than the right.)
444 ;; In the visualizer, the usual keys for moving up and down a buffer instead
445 ;; move up and down the undo history tree (e.g. the up and down arrow keys, or
446 ;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo
447 ;; history you are visualizing) is updated as you move around the undo tree in
448 ;; the visualizer. If you reach a branch point in the visualizer, the usual
449 ;; keys for moving forward and backward in a buffer instead switch branch
450 ;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). And clicking with
451 ;; the mouse on any node in the visualizer will take you directly to that
452 ;; node, resetting the state of the parent buffer to the state represented by
455 ;; It can be useful to see how long ago the parent buffer was in the state
456 ;; represented by a particular node in the visualizer. Hitting "t" in the
457 ;; visualizer toggles the display of time-stamps for all the nodes. (Note
458 ;; that, because of the way `undo-tree-mode' works, these time-stamps may be
459 ;; somewhat later than the true times, especially if it's been a long time
460 ;; since you last undid any changes.)
462 ;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in
463 ;; whatever state you ended at.
470 ;; Emacs allows a very useful and powerful method of undoing only selected
471 ;; changes: when a region is active, only changes that affect the text within
472 ;; that region will be undone. With the standard Emacs undo system, changes
473 ;; produced by undoing-in-region naturally get added onto the end of the
474 ;; linear undo history:
478 ;; | x (second undo-in-region)
481 ;; | o (first undo-in-region)
487 ;; You can of course redo these undos-in-region as usual, by undoing the
495 ;; | o o (undo the undo-in-region)
499 ;; o x (undo the undo-in-region)
502 ;; In `undo-tree-mode', undo-in-region works similarly: when there's an active
503 ;; region, undoing only undoes changes that affect that region. However, the
504 ;; way these undos-in-region are recorded in the undo history is quite
505 ;; different. In `undo-tree-mode', undo-in-region creates a new branch in the
506 ;; undo history. The new branch consists of an undo step that undoes some of
507 ;; the changes that affect the current region, and another step that undoes
508 ;; the remaining changes needed to rejoin the previous undo history.
510 ;; Previous undo history Undo-in-region
518 ;; o o x (undo-in-region)
523 ;; As long as you don't change the active region after undoing-in-region,
524 ;; continuing to undo-in-region extends the new branch, pulling more changes
525 ;; that affect the current region into an undo step immediately above your
526 ;; current location in the undo tree, and pushing the point at which the new
527 ;; branch is attached further up the tree:
529 ;; First undo-in-region Second undo-in-region
534 ;; o o x (undo-in-region)
542 ;; Redoing takes you back down the undo tree, as usual (as long as you haven't
543 ;; changed the active region after undoing-in-region, it doesn't matter if it
558 ;; What about redo-in-region? Obviously, this only makes sense if you have
559 ;; already undone some changes, so that there are some changes to redo!
560 ;; Redoing-in-region splits off a new branch of the undo history below your
561 ;; current location in the undo tree. This time, the new branch consists of a
562 ;; redo step that redoes some of the redo changes that affect the current
563 ;; region, followed by all the remaining redo changes.
565 ;; Previous undo history Redo-in-region
573 ;; o o x (redo-in-region)
578 ;; As long as you don't change the active region after redoing-in-region,
579 ;; continuing to redo-in-region extends the new branch, pulling more redo
580 ;; changes into a redo step immediately below your current location in the
583 ;; First redo-in-region Second redo-in-region
591 ;; o x (redo-in-region) o o
594 ;; o o o x (redo-in-region)
599 ;; Note that undo-in-region and redo-in-region only ever add new changes to
600 ;; the undo tree, they *never* modify existing undo history. So you can always
601 ;; return to previous buffer states by switching to a previous branch of the
609 ;; * added `term-mode' to `undo-tree-incompatible-major-modes'
612 ;; * added additional check in `undo-list-GCd-marker-elt-p' to guard against
613 ;; undo elements being mis-identified as marker elements.
614 ;; * fixed bug in `undo-list-transfer-to-tree'
617 ;; * use `get-buffer-create' when creating the visualizer buffer in
618 ;; `undo-tree-visualize', to fix bug caused by `global-undo-tree-mode' being
619 ;; enabled in the visualizer when `default-major-mode' is set to something
620 ;; other than `fundamental-mode' (thanks to Michael Heerdegen for suggesting
622 ;; * modified `turn-on-undo-tree-mode' to avoid turning on `undo-tree-mode' if
623 ;; the buffer's `major-mode' implements its own undo system, by checking
624 ;; whether `undo' is remapped, the default "C-/" or "C-_" bindings have been
625 ;; overridden, or the `major-mode' is listed in
626 ;; `undo-tree-incompatible-major-modes'
627 ;; * discard position entries from `buffer-undo-list' changesets created by
628 ;; undoing or redoing, to ensure point is always moved to where the change
629 ;; is (standard Emacs `undo' also does this)
630 ;; * fixed `undo-tree-draw-node' to use correct faces and indicate registers
631 ;; when displaying timestamps in visualizer
634 ;; * implemented undo-in-region
635 ;; * fixed bugs in `undo-list-transfer-to-tree' and
636 ;; `undo-list-rebuild-from-tree' which caused errors when undo history was
638 ;; * defun `region-active-p' if not already defined, for compatibility with
642 ;; * modified `undo-tree-node' defstruct and macros to allow arbitrary
643 ;; meta-data to be stored in a plist associated with a node, and
644 ;; reimplemented storage of visualizer data on top of this
645 ;; * display registers storing undo-tree state in visualizer
646 ;; * implemented keyboard selection in visualizer
647 ;; * rebuild `buffer-undo-list' from tree when disabling `undo-tree-mode'
650 ;; * added support for marker undo entries
653 ;; * pass null argument to `kill-buffer' call in `undo-tree-visualizer-quit',
654 ;; since the argument's not optional in earlier Emacs versions
655 ;; * added match for "No further redo information" to
656 ;; `debug-ignored-errors' to prevent debugger being called on this error
657 ;; * made `undo-tree-visualizer-quit' select the window displaying the
658 ;; visualizer's parent buffer, or switch to the parent buffer if no window
660 ;; * fixed bug in `undo-tree-switch-branch'
661 ;; * general code tidying and reorganisation
662 ;; * fixed bugs in history-discarding logic
663 ;; * fixed bug in `undo-tree-insert' triggered by `undo-tree-visualizer-set'
664 ;; by ensuring mark is deactivated
667 ;; * added `undo-tree-mode-lighter' customization option to allow the
668 ;; mode-line lighter to be changed
669 ;; * bug-fix in `undo-tree-discard-node'
670 ;; * added `undo-tree-save-state-to-register' and
671 ;; `undo-tree-restore-state-from-register' commands and keybindings for
672 ;; saving/restoring undo-tree states using registers
675 ;; * modified `undo-tree-visualize' to mark the visualizer window as
676 ;; soft-dedicated, and changed `undo-tree-visualizer-quit' to use
677 ;; `kill-buffer', so that the visualizer window is deleted along with its
678 ;; buffer if the visualizer buffer was displayed in a new window, but not if
679 ;; it was displayed in an existing window.
682 ;; * modified `undo-tree-undo' and `undo-tree-redo' to always replace
683 ;; redo/undo entries with new ones generated by `primitive-undo', as the new
684 ;; changesets will restore the point more reliably
687 ;; * fixed `undo-tree-visualizer-quit' to remove `after-change-functions'
688 ;; hook there, rather than in `undo-tree-kill-visualizer'
691 ;; * fixed keybindings
692 ;; * renamed `undo-tree-visualizer-switch-previous-branch' and
693 ;; `undo-tree-visualizer-switch-next-branch' to
694 ;; `undo-tree-visualizer-switch-branch-left' and
695 ;; `undo-tree-visualizer-switch-branch-right'
698 ;; * prevented `undo-tree-kill-visualizer' from killing visualizer when
699 ;; undoing/redoing from the visualizer, which completely broke the
701 ;; * changed one redo binding, so that at least one set of undo/redo bindings
702 ;; works in a terminal
703 ;; * bound vertical scrolling commands in `undo-tree-visualizer-map', in case
704 ;; they aren't bound globally
705 ;; * added missing :group argument to `defface's
714 (eval-when-compile (require 'cl))
716 ;; `characterp' isn't defined in Emacs versions <= 22
717 (unless (fboundp 'characterp)
718 (defalias 'characterp 'char-valid-p))
720 ;; `region-active-p' isn't defined in Emacs versions <= 22
721 (unless (fboundp 'region-active-p)
722 (defun region-active-p () (and transient-mark-mode mark-active)))
726 ;;; =====================================================================
727 ;;; Global variables and customization options
729 (defvar buffer-undo-tree nil
730 "Tree of undo entries in current buffer.")
731 (make-variable-buffer-local 'buffer-undo-tree)
734 (defgroup undo-tree nil
738 (defcustom undo-tree-mode-lighter " Undo-Tree"
739 "Lighter displayed in mode line
740 when `undo-tree-mode' is enabled."
744 (defcustom undo-tree-incompatible-major-modes '(term-mode)
745 "List of major-modes in which `undo-tree-mode' should not be enabled.
746 \(See `turn-on-undo-tree-mode'.\)"
748 :type '(repeat symbol))
750 (defcustom undo-tree-visualizer-spacing 3
751 "Horizontal spacing in undo-tree visualization.
752 Must be a postivie odd integer."
755 :match (lambda (w n) (and (integerp n) (> n 0) (= (mod n 2) 1)))))
756 (make-variable-buffer-local 'undo-tree-visualizer-spacing)
758 (defvar undo-tree-map nil
759 "Keymap used in undo-tree-mode.")
762 (defface undo-tree-visualizer-default-face
763 '((((class color)) :foreground "gray"))
764 "*Face used to draw undo-tree in visualizer."
767 (defface undo-tree-visualizer-current-face
768 '((((class color)) :foreground "red"))
769 "*Face used to highlight current undo-tree node in visualizer."
772 (defface undo-tree-visualizer-active-branch-face
773 '((((class color) (background dark))
774 (:foreground "white" :weight bold))
775 (((class color) (background light))
776 (:foreground "black" :weight bold)))
777 "*Face used to highlight active undo-tree branch
781 (defface undo-tree-visualizer-register-face
782 '((((class color)) :foreground "yellow"))
783 "*Face used to highlight undo-tree nodes saved to a register
787 (defvar undo-tree-visualizer-map nil
788 "Keymap used in undo-tree visualizer.")
790 (defvar undo-tree-visualizer-selection-map nil
791 "Keymap used in undo-tree visualizer selection mode.")
794 (defvar undo-tree-visualizer-parent-buffer nil
795 "Parent buffer in visualizer.")
796 (make-variable-buffer-local 'undo-tree-visualizer-parent-buffer)
798 (defvar undo-tree-visualizer-timestamps nil
799 "Non-nil when visualizer is displaying time-stamps.")
800 (make-variable-buffer-local 'undo-tree-visualizer-timestamps)
802 (defconst undo-tree-visualizer-buffer-name " *undo-tree*")
804 ;; prevent debugger being called on "No further redo information"
805 (add-to-list 'debug-ignored-errors "^No further redo information")
810 ;;; =================================================================
811 ;;; Setup default keymaps
813 (unless undo-tree-map
814 (setq undo-tree-map (make-sparse-keymap))
815 ;; remap `undo' and `undo-only' to `undo-tree-undo'
816 (define-key undo-tree-map [remap undo] 'undo-tree-undo)
817 (define-key undo-tree-map [remap undo-only] 'undo-tree-undo)
818 ;; bind standard undo bindings (since these match redo counterparts)
819 (define-key undo-tree-map (kbd "C-/") 'undo-tree-undo)
820 (define-key undo-tree-map "\C-_" 'undo-tree-undo)
821 ;; redo doesn't exist normally, so define our own keybindings
822 (define-key undo-tree-map (kbd "C-?") 'undo-tree-redo)
823 (define-key undo-tree-map (kbd "M-_") 'undo-tree-redo)
824 ;; just in case something has defined `redo'...
825 (define-key undo-tree-map [remap redo] 'undo-tree-redo)
826 ;; we use "C-x u" for the undo-tree visualizer
827 (define-key undo-tree-map (kbd "\C-x u") 'undo-tree-visualize)
828 ;; bind register commands
829 (define-key undo-tree-map (kbd "C-x r u")
830 'undo-tree-save-state-to-register)
831 (define-key undo-tree-map (kbd "C-x r U")
832 'undo-tree-restore-state-from-register))
835 (unless undo-tree-visualizer-map
836 (setq undo-tree-visualizer-map (make-keymap))
837 ;; vertical motion keys undo/redo
838 (define-key undo-tree-visualizer-map [remap previous-line]
839 'undo-tree-visualize-undo)
840 (define-key undo-tree-visualizer-map [remap next-line]
841 'undo-tree-visualize-redo)
842 (define-key undo-tree-visualizer-map [up]
843 'undo-tree-visualize-undo)
844 (define-key undo-tree-visualizer-map "p"
845 'undo-tree-visualize-undo)
846 (define-key undo-tree-visualizer-map "\C-p"
847 'undo-tree-visualize-undo)
848 (define-key undo-tree-visualizer-map [down]
849 'undo-tree-visualize-redo)
850 (define-key undo-tree-visualizer-map "n"
851 'undo-tree-visualize-redo)
852 (define-key undo-tree-visualizer-map "\C-n"
853 'undo-tree-visualize-redo)
854 ;; horizontal motion keys switch branch
855 (define-key undo-tree-visualizer-map [remap forward-char]
856 'undo-tree-visualize-switch-branch-right)
857 (define-key undo-tree-visualizer-map [remap backward-char]
858 'undo-tree-visualize-switch-branch-left)
859 (define-key undo-tree-visualizer-map [right]
860 'undo-tree-visualize-switch-branch-right)
861 (define-key undo-tree-visualizer-map "f"
862 'undo-tree-visualize-switch-branch-right)
863 (define-key undo-tree-visualizer-map "\C-f"
864 'undo-tree-visualize-switch-branch-right)
865 (define-key undo-tree-visualizer-map [left]
866 'undo-tree-visualize-switch-branch-left)
867 (define-key undo-tree-visualizer-map "b"
868 'undo-tree-visualize-switch-branch-left)
869 (define-key undo-tree-visualizer-map "\C-b"
870 'undo-tree-visualize-switch-branch-left)
871 ;; mouse sets buffer state to node at click
872 (define-key undo-tree-visualizer-map [mouse-1]
873 'undo-tree-visualizer-mouse-set)
875 (define-key undo-tree-visualizer-map "t"
876 'undo-tree-visualizer-toggle-timestamps)
878 (define-key undo-tree-visualizer-map "s"
879 'undo-tree-visualizer-selection-mode)
880 ;; horizontal scrolling may be needed if the tree is very wide
881 (define-key undo-tree-visualizer-map ","
882 'undo-tree-visualizer-scroll-left)
883 (define-key undo-tree-visualizer-map "."
884 'undo-tree-visualizer-scroll-right)
885 (define-key undo-tree-visualizer-map "<"
886 'undo-tree-visualizer-scroll-left)
887 (define-key undo-tree-visualizer-map ">"
888 'undo-tree-visualizer-scroll-right)
889 ;; vertical scrolling may be needed if the tree is very tall
890 (define-key undo-tree-visualizer-map [next] 'scroll-up)
891 (define-key undo-tree-visualizer-map [prior] 'scroll-down)
893 (define-key undo-tree-visualizer-map "q"
894 'undo-tree-visualizer-quit)
895 (define-key undo-tree-visualizer-map "\C-q"
896 'undo-tree-visualizer-quit))
899 (unless undo-tree-visualizer-selection-map
900 (setq undo-tree-visualizer-selection-map (make-keymap))
901 ;; vertical motion keys move up and down tree
902 (define-key undo-tree-visualizer-selection-map [remap previous-line]
903 'undo-tree-visualizer-select-previous)
904 (define-key undo-tree-visualizer-selection-map [remap next-line]
905 'undo-tree-visualizer-select-next)
906 (define-key undo-tree-visualizer-selection-map [up]
907 'undo-tree-visualizer-select-previous)
908 (define-key undo-tree-visualizer-selection-map "p"
909 'undo-tree-visualizer-select-previous)
910 (define-key undo-tree-visualizer-selection-map "\C-p"
911 'undo-tree-visualizer-select-previous)
912 (define-key undo-tree-visualizer-selection-map [down]
913 'undo-tree-visualizer-select-next)
914 (define-key undo-tree-visualizer-selection-map "n"
915 'undo-tree-visualizer-select-next)
916 (define-key undo-tree-visualizer-selection-map "\C-n"
917 'undo-tree-visualizer-select-next)
918 ;; vertical scroll keys move up and down quickly
919 (define-key undo-tree-visualizer-selection-map [next]
920 (lambda () (interactive) (undo-tree-visualizer-select-next 10)))
921 (define-key undo-tree-visualizer-selection-map [prior]
922 (lambda () (interactive) (undo-tree-visualizer-select-previous 10)))
923 ;; horizontal motion keys move to left and right siblings
924 (define-key undo-tree-visualizer-selection-map [remap forward-char]
925 'undo-tree-visualizer-select-right)
926 (define-key undo-tree-visualizer-selection-map [remap backward-char]
927 'undo-tree-visualizer-select-left)
928 (define-key undo-tree-visualizer-selection-map [right]
929 'undo-tree-visualizer-select-right)
930 (define-key undo-tree-visualizer-selection-map "f"
931 'undo-tree-visualizer-select-right)
932 (define-key undo-tree-visualizer-selection-map "\C-f"
933 'undo-tree-visualizer-select-right)
934 (define-key undo-tree-visualizer-selection-map [left]
935 'undo-tree-visualizer-select-left)
936 (define-key undo-tree-visualizer-selection-map "b"
937 'undo-tree-visualizer-select-left)
938 (define-key undo-tree-visualizer-selection-map "\C-b"
939 'undo-tree-visualizer-select-left)
940 ;; horizontal scroll keys move left or right quickly
941 (define-key undo-tree-visualizer-selection-map ","
942 (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
943 (define-key undo-tree-visualizer-selection-map "."
944 (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
945 (define-key undo-tree-visualizer-selection-map "<"
946 (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
947 (define-key undo-tree-visualizer-selection-map ">"
948 (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
949 ;; mouse or <enter> sets buffer state to node at point/click
950 (define-key undo-tree-visualizer-selection-map "\r"
951 'undo-tree-visualizer-set)
952 (define-key undo-tree-visualizer-selection-map [mouse-1]
953 'undo-tree-visualizer-mouse-set)
955 (define-key undo-tree-visualizer-selection-map "t"
956 'undo-tree-visualizer-toggle-timestamps)
957 ;; quit visualizer selection mode
958 (define-key undo-tree-visualizer-selection-map "s"
959 'undo-tree-visualizer-mode)
961 (define-key undo-tree-visualizer-selection-map "q"
962 'undo-tree-visualizer-quit)
963 (define-key undo-tree-visualizer-selection-map "\C-q"
964 'undo-tree-visualizer-quit))
969 ;;; =====================================================================
970 ;;; Undo-tree data structure
976 (:constructor make-undo-tree
978 (root (make-undo-tree-node nil nil))
981 (object-pool (make-hash-table :test 'eq :weakness 'value))))
983 root current size object-pool)
989 (:type vector) ; create unnamed struct
991 (:constructor make-undo-tree-node
995 (timestamp (current-time))
997 (:constructor make-undo-tree-node-backwards
1001 (next (list next-node))
1002 (timestamp (current-time))
1005 previous next undo redo timestamp branch meta-data)
1008 (defmacro undo-tree-node-p (n)
1009 (let ((len (length (make-undo-tree-node nil nil))))
1010 `(and (vectorp ,n) (= (length ,n) ,len))))
1015 (undo-tree-region-data
1016 (:type vector) ; create unnamed struct
1018 (:constructor make-undo-tree-region-data
1019 (&optional undo-beginning undo-end
1020 redo-beginning redo-end))
1021 (:constructor make-undo-tree-undo-region-data
1022 (undo-beginning undo-end))
1023 (:constructor make-undo-tree-redo-region-data
1024 (redo-beginning redo-end))
1026 undo-beginning undo-end redo-beginning redo-end)
1029 (defmacro undo-tree-region-data-p (r)
1030 (let ((len (length (make-undo-tree-region-data))))
1031 `(and (vectorp ,r) (= (length ,r) ,len))))
1033 (defmacro undo-tree-node-clear-region-data (node)
1034 `(setf (undo-tree-node-meta-data ,node)
1037 (plist-put (undo-tree-node-meta-data ,node)
1041 (defmacro undo-tree-node-undo-beginning (node)
1042 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1043 (when (undo-tree-region-data-p r)
1044 (undo-tree-region-data-undo-beginning r))))
1046 (defmacro undo-tree-node-undo-end (node)
1047 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1048 (when (undo-tree-region-data-p r)
1049 (undo-tree-region-data-undo-end r))))
1051 (defmacro undo-tree-node-redo-beginning (node)
1052 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1053 (when (undo-tree-region-data-p r)
1054 (undo-tree-region-data-redo-beginning r))))
1056 (defmacro undo-tree-node-redo-end (node)
1057 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1058 (when (undo-tree-region-data-p r)
1059 (undo-tree-region-data-redo-end r))))
1062 (defsetf undo-tree-node-undo-beginning (node) (val)
1063 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1064 (unless (undo-tree-region-data-p r)
1065 (setf (undo-tree-node-meta-data ,node)
1066 (plist-put (undo-tree-node-meta-data ,node) :region
1067 (setq r (make-undo-tree-region-data)))))
1068 (setf (undo-tree-region-data-undo-beginning r) ,val)))
1070 (defsetf undo-tree-node-undo-end (node) (val)
1071 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1072 (unless (undo-tree-region-data-p r)
1073 (setf (undo-tree-node-meta-data ,node)
1074 (plist-put (undo-tree-node-meta-data ,node) :region
1075 (setq r (make-undo-tree-region-data)))))
1076 (setf (undo-tree-region-data-undo-end r) ,val)))
1078 (defsetf undo-tree-node-redo-beginning (node) (val)
1079 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1080 (unless (undo-tree-region-data-p r)
1081 (setf (undo-tree-node-meta-data ,node)
1082 (plist-put (undo-tree-node-meta-data ,node) :region
1083 (setq r (make-undo-tree-region-data)))))
1084 (setf (undo-tree-region-data-redo-beginning r) ,val)))
1086 (defsetf undo-tree-node-redo-end (node) (val)
1087 `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
1088 (unless (undo-tree-region-data-p r)
1089 (setf (undo-tree-node-meta-data ,node)
1090 (plist-put (undo-tree-node-meta-data ,node) :region
1091 (setq r (make-undo-tree-region-data)))))
1092 (setf (undo-tree-region-data-redo-end r) ,val)))
1097 (undo-tree-visualizer-data
1098 (:type vector) ; create unnamed struct
1100 (:constructor make-undo-tree-visualizer-data
1101 (&optional lwidth cwidth rwidth marker))
1103 lwidth cwidth rwidth marker)
1106 (defmacro undo-tree-visualizer-data-p (v)
1107 (let ((len (length (make-undo-tree-visualizer-data))))
1108 `(and (vectorp ,v) (= (length ,v) ,len))))
1110 (defmacro undo-tree-node-clear-visualizer-data (node)
1111 `(setf (undo-tree-node-meta-data ,node)
1114 (plist-put (undo-tree-node-meta-data ,node)
1115 :visualizer nil)))))
1118 (defmacro undo-tree-node-lwidth (node)
1119 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1120 (when (undo-tree-visualizer-data-p v)
1121 (undo-tree-visualizer-data-lwidth v))))
1123 (defmacro undo-tree-node-cwidth (node)
1124 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1125 (when (undo-tree-visualizer-data-p v)
1126 (undo-tree-visualizer-data-cwidth v))))
1128 (defmacro undo-tree-node-rwidth (node)
1129 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1130 (when (undo-tree-visualizer-data-p v)
1131 (undo-tree-visualizer-data-rwidth v))))
1133 (defmacro undo-tree-node-marker (node)
1134 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1135 (when (undo-tree-visualizer-data-p v)
1136 (undo-tree-visualizer-data-marker v))))
1139 (defsetf undo-tree-node-lwidth (node) (val)
1140 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1141 (unless (undo-tree-visualizer-data-p v)
1142 (setf (undo-tree-node-meta-data ,node)
1143 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1144 (setq v (make-undo-tree-visualizer-data)))))
1145 (setf (undo-tree-visualizer-data-lwidth v) ,val)))
1147 (defsetf undo-tree-node-cwidth (node) (val)
1148 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1149 (unless (undo-tree-visualizer-data-p v)
1150 (setf (undo-tree-node-meta-data ,node)
1151 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1152 (setq v (make-undo-tree-visualizer-data)))))
1153 (setf (undo-tree-visualizer-data-cwidth v) ,val)))
1155 (defsetf undo-tree-node-rwidth (node) (val)
1156 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1157 (unless (undo-tree-visualizer-data-p v)
1158 (setf (undo-tree-node-meta-data ,node)
1159 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1160 (setq v (make-undo-tree-visualizer-data)))))
1161 (setf (undo-tree-visualizer-data-rwidth v) ,val)))
1163 (defsetf undo-tree-node-marker (node) (val)
1164 `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
1165 (unless (undo-tree-visualizer-data-p v)
1166 (setf (undo-tree-node-meta-data ,node)
1167 (plist-put (undo-tree-node-meta-data ,node) :visualizer
1168 (setq v (make-undo-tree-visualizer-data)))))
1169 (setf (undo-tree-visualizer-data-marker v) ,val)))
1173 (defmacro undo-tree-node-register (node)
1174 `(plist-get (undo-tree-node-meta-data ,node) :register))
1176 (defsetf undo-tree-node-register (node) (val)
1177 `(setf (undo-tree-node-meta-data ,node)
1178 (plist-put (undo-tree-node-meta-data ,node) :register ,val)))
1183 ;;; =====================================================================
1184 ;;; Basic undo-tree data structure functions
1186 (defun undo-tree-grow (undo)
1187 "Add an UNDO node to current branch of `buffer-undo-tree'."
1188 (let* ((current (undo-tree-current buffer-undo-tree))
1189 (new (make-undo-tree-node current undo)))
1190 (push new (undo-tree-node-next current))
1191 (setf (undo-tree-current buffer-undo-tree) new)))
1194 (defun undo-tree-grow-backwards (node undo &optional redo)
1195 "Add new node *above* undo-tree NODE, and return new node.
1196 Note that this will overwrite NODE's \"previous\" link, so should
1197 only be used on a detached NODE, never on nodes that are already
1198 part of `buffer-undo-tree'."
1199 (let ((new (make-undo-tree-node-backwards node undo redo)))
1200 (setf (undo-tree-node-previous node) new)
1204 (defun undo-tree-splice-node (node splice)
1205 "Splice NODE into undo tree, below node SPLICE.
1206 Note that this will overwrite NODE's \"next\" and \"previous\"
1207 links, so should only be used on a detached NODE, never on nodes
1208 that are already part of `buffer-undo-tree'."
1209 (setf (undo-tree-node-next node) (undo-tree-node-next splice)
1210 (undo-tree-node-branch node) (undo-tree-node-branch splice)
1211 (undo-tree-node-previous node) splice
1212 (undo-tree-node-next splice) (list node)
1213 (undo-tree-node-branch splice) 0)
1214 (dolist (n (undo-tree-node-next node))
1215 (setf (undo-tree-node-previous n) node)))
1218 (defun undo-tree-snip-node (node)
1219 "Snip NODE out of undo tree."
1220 (let* ((parent (undo-tree-node-previous node))
1222 ;; if NODE is only child, replace parent's next links with NODE's
1223 (if (= (length (undo-tree-node-next parent)) 0)
1224 (setf (undo-tree-node-next parent) (undo-tree-node-next node)
1225 (undo-tree-node-branch parent) (undo-tree-node-branch node))
1227 (setq position (undo-tree-position node (undo-tree-node-next parent)))
1229 ;; if active branch used do go via NODE, set parent's branch to active
1231 ((= (undo-tree-node-branch parent) position)
1232 (setf (undo-tree-node-branch parent)
1233 (+ position (undo-tree-node-branch node))))
1234 ;; if active branch didn't go via NODE, update parent's branch to point
1235 ;; to same node as before
1236 ((> (undo-tree-node-branch parent) position)
1237 (incf (undo-tree-node-branch parent)
1238 (1- (length (undo-tree-node-next node))))))
1239 ;; replace NODE in parent's next list with NODE's entire next list
1241 (setf (undo-tree-node-next parent)
1242 (nconc (undo-tree-node-next node)
1243 (cdr (undo-tree-node-next parent))))
1244 (setq p (nthcdr (1- position) (undo-tree-node-next parent)))
1245 (setcdr p (nconc (undo-tree-node-next node) (cddr p)))))
1246 ;; update previous links of NODE's children
1247 (dolist (n (undo-tree-node-next node))
1248 (setf (undo-tree-node-previous n) parent))))
1251 (defun undo-tree-mapc (--undo-tree-mapc-function-- undo-tree)
1252 ;; Apply FUNCTION to each node in UNDO-TREE.
1253 (let ((stack (list (undo-tree-root undo-tree)))
1256 (setq node (pop stack))
1257 (funcall --undo-tree-mapc-function-- node)
1258 (setq stack (append (undo-tree-node-next node) stack)))))
1261 (defmacro undo-tree-num-branches ()
1262 "Return number of branches at current undo tree node."
1263 '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree))))
1266 (defun undo-tree-position (node list)
1267 "Find the first occurrence of NODE in LIST.
1268 Return the index of the matching item, or nil of not found.
1269 Comparison is done with `eq'."
1273 (when (eq node (car list)) (throw 'found i))
1275 (setq list (cdr list))))
1279 (defvar *undo-tree-id-counter* 0)
1280 (make-variable-buffer-local '*undo-tree-id-counter*)
1282 (defmacro undo-tree-generate-id ()
1283 ;; Generate a new, unique id (uninterned symbol).
1284 ;; The name is made by appending a number to "undo-tree-id".
1285 ;; (Copied from CL package `gensym'.)
1286 `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*))))
1287 (make-symbol (format "undo-tree-id%d" num))))
1292 ;;; =====================================================================
1293 ;;; Utility functions for handling `buffer-undo-list' and changesets
1295 (defmacro undo-list-marker-elt-p (elt)
1296 `(markerp (car-safe ,elt)))
1298 (defmacro undo-list-GCd-marker-elt-p (elt)
1299 ;; Return t if ELT is a marker element whose marker has been moved to the
1300 ;; object-pool, so may potentially have been garbage-collected.
1301 ;; Note: Valid marker undo elements should be uniquely identified as cons
1302 ;; cells with a symbol in the car (replacing the marker), and a number in
1303 ;; the cdr. However, to guard against future changes to undo element
1304 ;; formats, we perform an additional redundant check on the symbol name.
1305 `(and (car-safe ,elt)
1306 (symbolp (car ,elt))
1307 (let ((str (symbol-name (car ,elt))))
1308 (and (> (length str) 12)
1309 (string= (substring str 0 12) "undo-tree-id")))
1310 (numberp (cdr-safe ,elt))))
1313 (defun undo-tree-move-GC-elts-to-pool (elt)
1314 ;; Move elements that can be garbage-collected into `buffer-undo-tree'
1315 ;; object pool, substituting a unique id that can be used to retrieve them
1316 ;; later. (Only markers require this treatment currently.)
1317 (when (undo-list-marker-elt-p elt)
1318 (let ((id (undo-tree-generate-id)))
1319 (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree))
1323 (defun undo-tree-restore-GC-elts-from-pool (elt)
1324 ;; Replace object id's in ELT with corresponding objects from
1325 ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if
1326 ;; any object in ELT has been garbage-collected.
1327 (if (undo-list-GCd-marker-elt-p elt)
1328 (when (setcar elt (gethash (car elt)
1329 (undo-tree-object-pool buffer-undo-tree)))
1334 (defun undo-list-clean-GCd-elts (undo-list)
1335 ;; Remove object id's from UNDO-LIST that refer to elements that have been
1336 ;; garbage-collected. UNDO-LIST is modified by side-effect.
1337 (while (undo-list-GCd-marker-elt-p (car undo-list))
1338 (unless (gethash (caar undo-list)
1339 (undo-tree-object-pool buffer-undo-tree))
1340 (setq undo-list (cdr undo-list))))
1341 (let ((p undo-list))
1343 (when (and (undo-list-GCd-marker-elt-p (cadr p))
1344 (null (gethash (car (cadr p))
1345 (undo-tree-object-pool buffer-undo-tree))))
1346 (setcdr p (cddr p)))
1351 (defun undo-list-pop-changeset (&optional discard-pos)
1352 ;; Pop changeset from `buffer-undo-list'. If DISCARD-POS is non-nil, discard
1353 ;; any position entries from changeset.
1355 ;; discard undo boundaries and (if DISCARD-POS is non-nil) position entries
1356 ;; at head of undo list
1357 (while (or (null (car buffer-undo-list))
1358 (and discard-pos (integerp (car buffer-undo-list))))
1359 (setq buffer-undo-list (cdr buffer-undo-list)))
1360 ;; pop elements up to next undo boundary
1361 (unless (eq (car buffer-undo-list) 'undo-tree-canary)
1362 (let* ((changeset (list (pop buffer-undo-list)))
1365 (undo-tree-move-GC-elts-to-pool (car p))
1366 (car buffer-undo-list))
1367 ;; discard position entries at head of undo list
1369 (while (and discard-pos (integerp (car buffer-undo-list)))
1370 (setq buffer-undo-list (cdr buffer-undo-list))))
1371 (setcdr p (list (pop buffer-undo-list)))
1376 (defun undo-tree-copy-list (undo-list)
1377 ;; Return a deep copy of first changeset in `undo-list'. Object id's are
1378 ;; replaced by corresponding objects from `buffer-undo-tree' object-pool.
1381 ;; if first element contains an object id, replace it with object from
1382 ;; pool, discarding element entirely if it's been GC'd
1385 (undo-tree-restore-GC-elts-from-pool (pop undo-list))))
1386 (setq copy (list copy)
1388 ;; copy remaining elements, replacing object id's with objects from
1389 ;; pool, or discarding them entirely if they've been GC'd
1391 (when (setcdr p (undo-tree-restore-GC-elts-from-pool
1392 (undo-copy-list-1 (pop undo-list))))
1393 (setcdr p (list (cdr p)))
1399 (defun undo-list-transfer-to-tree ()
1400 ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'.
1402 ;; if `buffer-undo-tree' is empty, create initial undo-tree
1403 (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree)))
1404 ;; make sure there's a canary at end of `buffer-undo-list'
1405 (when (null buffer-undo-list)
1406 (setq buffer-undo-list '(nil undo-tree-canary)))
1408 (unless (eq (cadr buffer-undo-list) 'undo-tree-canary)
1409 ;; create new node from first changeset in `buffer-undo-list', save old
1410 ;; `buffer-undo-tree' current node, and make new node the current node
1411 (let* ((node (make-undo-tree-node nil (undo-list-pop-changeset)))
1412 (splice (undo-tree-current buffer-undo-tree))
1413 (size (undo-list-byte-size (undo-tree-node-undo node))))
1414 (setf (undo-tree-current buffer-undo-tree) node)
1415 ;; grow tree fragment backwards using `buffer-undo-list' changesets
1416 (while (and buffer-undo-list
1417 (not (eq (cadr buffer-undo-list) 'undo-tree-canary)))
1419 (undo-tree-grow-backwards node (undo-list-pop-changeset)))
1420 (incf size (undo-list-byte-size (undo-tree-node-undo node))))
1421 ;; if no undo history has been discarded from `buffer-undo-list' since
1422 ;; last transfer, splice new tree fragment onto end of old
1423 ;; `buffer-undo-tree' current node
1424 (if (eq (cadr buffer-undo-list) 'undo-tree-canary)
1426 (setf (undo-tree-node-previous node) splice)
1427 (push node (undo-tree-node-next splice))
1428 (setf (undo-tree-node-branch splice) 0)
1429 (incf (undo-tree-size buffer-undo-tree) size))
1430 ;; if undo history has been discarded, replace entire
1431 ;; `buffer-undo-tree' with new tree fragment
1432 (setq node (undo-tree-grow-backwards node nil))
1433 (setf (undo-tree-root buffer-undo-tree) node)
1434 (setq buffer-undo-list '(nil undo-tree-canary))
1435 (setf (undo-tree-size buffer-undo-tree) size)
1436 (setq buffer-undo-list '(nil undo-tree-canary))))
1437 ;; discard undo history if necessary
1438 (undo-tree-discard-history)))
1441 (defun undo-list-byte-size (undo-list)
1442 ;; Return size (in bytes) of UNDO-LIST
1443 (let ((size 0) (p undo-list))
1445 (incf size 8) ; cons cells use up 8 bytes
1446 (when (and (consp (car p)) (stringp (caar p)))
1447 (incf size (string-bytes (caar p))))
1453 (defun undo-list-rebuild-from-tree ()
1454 "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'."
1455 (unless (eq buffer-undo-list t)
1456 (undo-list-transfer-to-tree)
1457 (setq buffer-undo-list nil)
1458 (when buffer-undo-tree
1459 (let ((stack (list (list (undo-tree-root buffer-undo-tree)))))
1460 (push (sort (mapcar 'identity (undo-tree-node-next (caar stack)))
1462 (time-less-p (undo-tree-node-timestamp a)
1463 (undo-tree-node-timestamp b))))
1465 ;; Traverse tree in depth-and-oldest-first order, but add undo records
1466 ;; on the way down, and redo records on the way up.
1467 (while (or (car stack)
1468 (not (eq (car (nth 1 stack))
1469 (undo-tree-current buffer-undo-tree))))
1472 (setq buffer-undo-list
1473 (append (undo-tree-node-undo (caar stack))
1476 (push (sort (mapcar 'identity
1477 (undo-tree-node-next (caar stack)))
1479 (time-less-p (undo-tree-node-timestamp a)
1480 (undo-tree-node-timestamp b))))
1483 (setq buffer-undo-list
1484 (append (undo-tree-node-redo (caar stack))
1487 (pop (car stack))))))))
1492 ;;; =====================================================================
1493 ;;; History discarding functions
1495 (defun undo-tree-oldest-leaf (node)
1496 ;; Return oldest leaf node below NODE.
1497 (while (undo-tree-node-next node)
1499 (car (sort (mapcar 'identity (undo-tree-node-next node))
1501 (time-less-p (undo-tree-node-timestamp a)
1502 (undo-tree-node-timestamp b)))))))
1506 (defun undo-tree-discard-node (node)
1507 ;; Discard NODE from `buffer-undo-tree', and return next in line for
1510 ;; don't discard current node
1511 (unless (eq node (undo-tree-current buffer-undo-tree))
1513 ;; discarding root node...
1514 (if (eq node (undo-tree-root buffer-undo-tree))
1516 ;; should always discard branches before root
1517 ((> (length (undo-tree-node-next node)) 1)
1518 (error "Trying to discard undo-tree root which still\
1519 has multiple branches"))
1520 ;; don't discard root if current node is only child
1521 ((eq (car (undo-tree-node-next node))
1522 (undo-tree-current buffer-undo-tree))
1526 ;; clear any register referring to root
1527 (let ((r (undo-tree-node-register node)))
1528 (when (and r (eq (get-register r) node))
1529 (set-register r nil)))
1530 ;; make child of root into new root
1531 (setq node (setf (undo-tree-root buffer-undo-tree)
1532 (car (undo-tree-node-next node))))
1533 ;; update undo-tree size
1534 (decf (undo-tree-size buffer-undo-tree)
1535 (+ (undo-list-byte-size (undo-tree-node-undo node))
1536 (undo-list-byte-size (undo-tree-node-redo node))))
1537 ;; discard new root's undo data
1538 (setf (undo-tree-node-undo node) nil
1539 (undo-tree-node-redo node) nil)
1540 ;; if new root has branches, or new root is current node, next node
1541 ;; to discard is oldest leaf, otherwise it's new root
1542 (if (or (> (length (undo-tree-node-next node)) 1)
1543 (eq (car (undo-tree-node-next node))
1544 (undo-tree-current buffer-undo-tree)))
1545 (undo-tree-oldest-leaf node)
1548 ;; discarding leaf node...
1549 (let* ((parent (undo-tree-node-previous node))
1550 (current (nth (undo-tree-node-branch parent)
1551 (undo-tree-node-next parent))))
1552 ;; clear any register referring to the discarded node
1553 (let ((r (undo-tree-node-register node)))
1554 (when (and r (eq (get-register r) node))
1555 (set-register r nil)))
1556 ;; update undo-tree size
1557 (decf (undo-tree-size buffer-undo-tree)
1558 (+ (undo-list-byte-size (undo-tree-node-undo node))
1559 (undo-list-byte-size (undo-tree-node-redo node))))
1560 (setf (undo-tree-node-next parent)
1561 (delq node (undo-tree-node-next parent))
1562 (undo-tree-node-branch parent)
1563 (undo-tree-position current (undo-tree-node-next parent)))
1564 ;; if parent has branches, or parent is current node, next node to
1565 ;; discard is oldest leaf, otherwise it's parent
1566 (if (or (eq parent (undo-tree-current buffer-undo-tree))
1567 (and (undo-tree-node-next parent)
1568 (or (not (eq parent (undo-tree-root buffer-undo-tree)))
1569 (> (length (undo-tree-node-next parent)) 1))))
1570 (undo-tree-oldest-leaf parent)
1575 (defun undo-tree-discard-history ()
1576 "Discard undo history until we're within memory usage limits
1577 set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'."
1579 (when (> (undo-tree-size buffer-undo-tree) undo-limit)
1580 ;; if there are no branches off root, first node to discard is root;
1581 ;; otherwise it's leaf node at botom of oldest branch
1582 (let ((node (if (> (length (undo-tree-node-next
1583 (undo-tree-root buffer-undo-tree))) 1)
1584 (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree))
1585 (undo-tree-root buffer-undo-tree))))
1587 ;; discard nodes until memory use is within `undo-strong-limit'
1589 (> (undo-tree-size buffer-undo-tree) undo-strong-limit))
1590 (setq node (undo-tree-discard-node node)))
1592 ;; discard nodes until next node to discard would bring memory use
1593 ;; within `undo-limit'
1595 ;; check first if last discard has brought us within
1596 ;; `undo-limit', in case we can avoid more expensive
1597 ;; `undo-strong-limit' calculation
1598 ;; Note: this assumes undo-strong-limit > undo-limit;
1599 ;; if not, effectively undo-strong-limit = undo-limit
1600 (> (undo-tree-size buffer-undo-tree) undo-limit)
1601 (> (- (undo-tree-size buffer-undo-tree)
1602 ;; if next node to discard is root, the memory we
1603 ;; free-up comes from discarding changesets from its
1605 (if (eq node (undo-tree-root buffer-undo-tree))
1606 (+ (undo-list-byte-size
1607 (undo-tree-node-undo
1608 (car (undo-tree-node-next node))))
1609 (undo-list-byte-size
1610 (undo-tree-node-redo
1611 (car (undo-tree-node-next node)))))
1612 ;; ...otherwise, it comes from discarding changesets
1613 ;; from along with the node itself
1614 (+ (undo-list-byte-size (undo-tree-node-undo node))
1615 (undo-list-byte-size (undo-tree-node-redo node)))
1618 (setq node (undo-tree-discard-node node)))
1620 ;; if we're still over the `undo-outer-limit', discard entire history
1621 (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit)
1622 ;; query first if `undo-ask-before-discard' is set
1623 (if undo-ask-before-discard
1626 "Buffer `%s' undo info is %d bytes long; discard it? "
1627 (buffer-name) (undo-tree-size buffer-undo-tree)))
1628 (setq buffer-undo-tree nil))
1629 ;; otherwise, discard and display warning
1631 '(undo discard-info)
1633 (format "Buffer `%s' undo info was %d bytes long.\n"
1634 (buffer-name) (undo-tree-size buffer-undo-tree))
1635 "The undo info was discarded because it exceeded\
1638 This is normal if you executed a command that made a huge change
1639 to the buffer. In that case, to prevent similar problems in the
1640 future, set `undo-outer-limit' to a value that is large enough to
1641 cover the maximum size of normal changes you expect a single
1642 command to make, but not so large that it might exceed the
1643 maximum memory allotted to Emacs.
1645 If you did not execute any such command, the situation is
1646 probably due to a bug and you should report it.
1648 You can disable the popping up of this buffer by adding the entry
1649 \(undo discard-info) to the user option `warning-suppress-types',
1650 which is defined in the `warnings' library.\n")
1652 (setq buffer-undo-tree nil)))
1658 ;;; =====================================================================
1659 ;;; Visualizer-related functions
1661 (defun undo-tree-compute-widths (undo-tree)
1662 "Recursively compute widths for all UNDO-TREE's nodes."
1663 (let ((stack (list (undo-tree-root undo-tree)))
1666 ;; try to compute widths for node at top of stack
1667 (if (undo-tree-node-p
1668 (setq res (undo-tree-node-compute-widths (car stack))))
1669 ;; if computation fails, it returns a node whose widths still need
1670 ;; computing, which we push onto the stack
1672 ;; otherwise, store widths and remove it from stack
1673 (setf (undo-tree-node-lwidth (car stack)) (aref res 0)
1674 (undo-tree-node-cwidth (car stack)) (aref res 1)
1675 (undo-tree-node-rwidth (car stack)) (aref res 2))
1679 (defun undo-tree-node-compute-widths (node)
1680 ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths
1681 ;; (in a vector) if successful. Otherwise, returns a node whose widths need
1682 ;; calculating before NODE's can be calculated.
1683 (let ((num-children (length (undo-tree-node-next node)))
1684 (lwidth 0) (cwidth 0) (rwidth 0)
1688 ;; leaf nodes have 0 width
1691 (undo-tree-node-lwidth node) 0
1692 (undo-tree-node-cwidth node) 1
1693 (undo-tree-node-rwidth node) 0))
1695 ;; odd number of children
1696 ((= (mod num-children 2) 1)
1697 (setq p (undo-tree-node-next node))
1698 ;; compute left-width
1699 (dotimes (i (/ num-children 2))
1700 (if (undo-tree-node-lwidth (car p))
1701 (incf lwidth (+ (undo-tree-node-lwidth (car p))
1702 (undo-tree-node-cwidth (car p))
1703 (undo-tree-node-rwidth (car p))))
1704 ;; if child's widths haven't been computed, return that child
1705 (throw 'need-widths (car p)))
1707 (if (undo-tree-node-lwidth (car p))
1708 (incf lwidth (undo-tree-node-lwidth (car p)))
1709 (throw 'need-widths (car p)))
1710 ;; centre-width is inherited from middle child
1711 (setf cwidth (undo-tree-node-cwidth (car p)))
1712 ;; compute right-width
1713 (incf rwidth (undo-tree-node-rwidth (car p)))
1715 (dotimes (i (/ num-children 2))
1716 (if (undo-tree-node-lwidth (car p))
1717 (incf rwidth (+ (undo-tree-node-lwidth (car p))
1718 (undo-tree-node-cwidth (car p))
1719 (undo-tree-node-rwidth (car p))))
1720 (throw 'need-widths (car p)))
1723 ;; even number of children
1725 (setq p (undo-tree-node-next node))
1726 ;; compute left-width
1727 (dotimes (i (/ num-children 2))
1728 (if (undo-tree-node-lwidth (car p))
1729 (incf lwidth (+ (undo-tree-node-lwidth (car p))
1730 (undo-tree-node-cwidth (car p))
1731 (undo-tree-node-rwidth (car p))))
1732 (throw 'need-widths (car p)))
1734 ;; centre-width is 0 when number of children is even
1736 ;; compute right-width
1737 (dotimes (i (/ num-children 2))
1738 (if (undo-tree-node-lwidth (car p))
1739 (incf rwidth (+ (undo-tree-node-lwidth (car p))
1740 (undo-tree-node-cwidth (car p))
1741 (undo-tree-node-rwidth (car p))))
1742 (throw 'need-widths (car p)))
1745 ;; return left-, centre- and right-widths
1746 (vector lwidth cwidth rwidth))))
1749 (defun undo-tree-clear-visualizer-data (undo-tree)
1750 ;; Clear visualizer data from UNDO-TREE.
1752 (lambda (node) (undo-tree-node-clear-visualizer-data node))
1758 ;;; =====================================================================
1759 ;;; Undo-in-region functions
1761 (defun undo-tree-pull-undo-in-region-branch (start end)
1762 ;; Pull out entries from undo changesets to create a new undo-in-region
1763 ;; branch, which undoes changeset entries lying between START and END first,
1764 ;; followed by remaining entries from the changesets, before rejoining the
1765 ;; existing undo tree history. Repeated calls will, if appropriate, extend
1766 ;; the current undo-in-region branch rather than creating a new one.
1768 ;; if we're just reverting the last redo-in-region, we don't need to
1769 ;; manipulate the undo tree at all
1770 (if (undo-tree-reverting-redo-in-region-p start end)
1771 t ; return t to indicate success
1773 ;; We build the `region-changeset' and `delta-list' lists forwards, using
1774 ;; pointers `r' and `d' to the penultimate element of the list. So that we
1775 ;; don't have to treat the first element differently, we prepend a dummy
1776 ;; leading nil to the lists, and have the pointers point to that
1778 ;; Note: using '(nil) instead of (list nil) in the `let*' results in
1779 ;; bizarre errors when the code is byte-compiled, where parts of the
1780 ;; lists appear to survive across different calls to this function.
1781 ;; An obscure byte-compiler bug, perhaps?
1782 (let* ((region-changeset (list nil))
1783 (r region-changeset)
1784 (delta-list (list nil))
1786 (node (undo-tree-current buffer-undo-tree))
1787 (repeated-undo-in-region
1788 (undo-tree-repeated-undo-in-region-p start end))
1789 undo-adjusted-markers ; `undo-elt-in-region' expects this
1790 fragment splice original-fragment original-splice original-current
1791 got-visible-elt undo-list elt)
1793 ;; --- initialisation ---
1795 ;; if this is a repeated undo in the same region, start pulling changes
1796 ;; from NODE at which undo-in-region branch iss attached, and detatch
1797 ;; the branch, using it as initial FRAGMENT of branch being constructed
1798 (repeated-undo-in-region
1799 (setq original-current node
1800 fragment (car (undo-tree-node-next node))
1802 ;; undo up to node at which undo-in-region branch is attached
1803 ;; (recognizable as first node with more than one branch)
1804 (let ((mark-active nil))
1805 (while (= (length (undo-tree-node-next node)) 1)
1808 node (undo-tree-current buffer-undo-tree))))
1809 (when (eq splice node) (setq splice nil))
1810 ;; detatch undo-in-region branch
1811 (setf (undo-tree-node-next node)
1812 (delq fragment (undo-tree-node-next node))
1813 (undo-tree-node-previous fragment) nil
1814 original-fragment fragment
1815 original-splice node))
1817 ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all
1818 ;; nodes below the current one in the active branch
1819 ((undo-tree-node-next node)
1820 (setq fragment (make-undo-tree-node nil nil)
1822 (while (setq node (nth (undo-tree-node-branch node)
1823 (undo-tree-node-next node)))
1824 (push (make-undo-tree-node
1826 (undo-copy-list (undo-tree-node-undo node))
1827 (undo-copy-list (undo-tree-node-redo node)))
1828 (undo-tree-node-next splice))
1829 (setq splice (car (undo-tree-node-next splice))))
1830 (setq fragment (car (undo-tree-node-next fragment))
1832 node (undo-tree-current buffer-undo-tree))))
1835 ;; --- pull undo-in-region elements into branch ---
1836 ;; work backwards up tree, pulling out undo elements within region until
1837 ;; we've got one that undoes a visible change (insertion or deletion)
1839 (while (and (not got-visible-elt) node (undo-tree-node-undo node))
1840 ;; we cons a dummy nil element on the front of the changeset so that
1841 ;; we can conveniently remove the first (real) element from the
1842 ;; changeset if we need to; the leading nil is removed once we're
1843 ;; done with this changeset
1844 (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node)))
1845 elt (cadr undo-list))
1848 (setq fragment (undo-tree-grow-backwards fragment undo-list))
1849 (unless splice (setq splice fragment)))
1850 (setq fragment (make-undo-tree-node nil undo-list))
1851 (setq splice fragment))
1855 ;; keep elements within region
1856 ((undo-elt-in-region elt start end)
1857 ;; set flag if kept element is visible (insertion or deletion)
1858 (when (and (consp elt)
1859 (or (stringp (car elt)) (integerp (car elt))))
1860 (setq got-visible-elt t))
1861 ;; adjust buffer positions in elements previously undone before
1862 ;; kept element, as kept element will now be undone first
1863 (undo-tree-adjust-elements-to-elt splice elt)
1864 ;; move kept element to undo-in-region changeset, adjusting its
1865 ;; buffer position as it will now be undone first
1866 (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list))))
1868 (setcdr undo-list (cddr undo-list)))
1870 ;; discard "was unmodified" elements
1871 ;; FIXME: deal properly with these
1872 ((and (consp elt) (eq (car elt) t))
1873 (setcdr undo-list (cddr undo-list)))
1875 ;; if element crosses region, we can't pull any more elements
1876 ((undo-elt-crosses-region elt start end)
1877 ;; if we've found a visible element, it must be earlier in
1878 ;; current node's changeset; stop pulling elements (null
1879 ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit)
1881 (setq undo-list nil)
1882 ;; if we haven't found a visible element yet, pulling
1883 ;; undo-in-region branch has failed
1884 (setq region-changeset nil)
1887 ;; if rejecting element, add its delta (if any) to the list
1889 (let ((delta (undo-delta elt)))
1890 (when (/= 0 (cdr delta))
1891 (setcdr d (list delta))
1893 (setq undo-list (cdr undo-list))))
1895 ;; process next element of current changeset
1896 (setq elt (cadr undo-list)))
1898 ;; if there are remaining elements in changeset, remove dummy nil
1900 (if (cadr (undo-tree-node-undo fragment))
1901 (pop (undo-tree-node-undo fragment))
1902 ;; otherwise, if we've kept all elements in changeset, discard
1904 (when (eq splice fragment) (setq splice nil))
1905 (setq fragment (car (undo-tree-node-next fragment))))
1906 ;; process changeset from next node up the tree
1907 (setq node (undo-tree-node-previous node))))
1909 ;; pop dummy nil from front of `region-changeset'
1910 (pop region-changeset)
1913 ;; --- integrate branch into tree ---
1914 ;; if no undo-in-region elements were found, restore undo tree
1915 (if (null region-changeset)
1916 (when original-current
1917 (push original-fragment (undo-tree-node-next original-splice))
1918 (setf (undo-tree-node-branch original-splice) 0
1919 (undo-tree-node-previous original-fragment) original-splice)
1920 (let ((mark-active nil))
1921 (while (not (eq (undo-tree-current buffer-undo-tree)
1924 nil) ; return nil to indicate failure
1927 ;; need to undo up to node where new branch will be attached, to
1928 ;; ensure redo entries are populated, and then redo back to where we
1930 (let ((mark-active nil)
1931 (current (undo-tree-current buffer-undo-tree)))
1932 (while (not (eq (undo-tree-current buffer-undo-tree) node))
1934 (while (not (eq (undo-tree-current buffer-undo-tree) current))
1938 ;; if there's no remaining fragment, just create undo-in-region node
1939 ;; and attach it to parent of last node from which elements were
1942 (setq fragment (make-undo-tree-node node region-changeset))
1943 (push fragment (undo-tree-node-next node))
1944 (setf (undo-tree-node-branch node) 0)
1945 ;; set current node to undo-in-region node
1946 (setf (undo-tree-current buffer-undo-tree) fragment))
1948 ;; if no splice point has been set, add undo-in-region node to top of
1949 ;; fragment and attach it to parent of last node from which elements
1952 (setq fragment (undo-tree-grow-backwards fragment region-changeset))
1953 (push fragment (undo-tree-node-next node))
1954 (setf (undo-tree-node-branch node) 0
1955 (undo-tree-node-previous fragment) node)
1956 ;; set current node to undo-in-region node
1957 (setf (undo-tree-current buffer-undo-tree) fragment))
1959 ;; if fragment contains nodes, attach fragment to parent of last node
1960 ;; from which elements were pulled, and splice in undo-in-region node
1962 (setf (undo-tree-node-previous fragment) node)
1963 (push fragment (undo-tree-node-next node))
1964 (setf (undo-tree-node-branch node) 0)
1965 ;; if this is a repeated undo-in-region, then we've left the current
1966 ;; node at the original splice-point; we need to set the current
1967 ;; node to the equivalent node on the undo-in-region branch and redo
1968 ;; back to where we started
1969 (when repeated-undo-in-region
1970 (setf (undo-tree-current buffer-undo-tree)
1971 (undo-tree-node-previous original-fragment))
1972 (let ((mark-active nil))
1973 (while (not (eq (undo-tree-current buffer-undo-tree) splice))
1974 (undo-tree-redo nil 'preserve-undo))))
1975 ;; splice new undo-in-region node into fragment
1976 (setq node (make-undo-tree-node nil region-changeset))
1977 (undo-tree-splice-node node splice)
1978 ;; set current node to undo-in-region node
1979 (setf (undo-tree-current buffer-undo-tree) node)))
1981 ;; update undo-tree size
1982 (setq node (undo-tree-node-previous fragment))
1984 (and (setq node (car (undo-tree-node-next node)))
1985 (not (eq node original-fragment))
1986 (incf (undo-tree-size buffer-undo-tree)
1987 (undo-list-byte-size (undo-tree-node-undo node)))
1988 (when (undo-tree-node-redo node)
1989 (incf (undo-tree-size buffer-undo-tree)
1990 (undo-list-byte-size (undo-tree-node-redo node))))
1992 t) ; indicate undo-in-region branch was successfully pulled
1997 (defun undo-tree-pull-redo-in-region-branch (start end)
1998 ;; Pull out entries from redo changesets to create a new redo-in-region
1999 ;; branch, which redoes changeset entries lying between START and END first,
2000 ;; followed by remaining entries from the changesets. Repeated calls will,
2001 ;; if appropriate, extend the current redo-in-region branch rather than
2002 ;; creating a new one.
2004 ;; if we're just reverting the last undo-in-region, we don't need to
2005 ;; manipulate the undo tree at all
2006 (if (undo-tree-reverting-undo-in-region-p start end)
2007 t ; return t to indicate success
2009 ;; We build the `region-changeset' and `delta-list' lists forwards, using
2010 ;; pointers `r' and `d' to the penultimate element of the list. So that we
2011 ;; don't have to treat the first element differently, we prepend a dummy
2012 ;; leading nil to the lists, and have the pointers point to that
2014 ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre
2015 ;; errors when the code is byte-compiled, where parts of the lists
2016 ;; appear to survive across different calls to this function. An
2017 ;; obscure byte-compiler bug, perhaps?
2018 (let* ((region-changeset (list nil))
2019 (r region-changeset)
2020 (delta-list (list nil))
2022 (node (undo-tree-current buffer-undo-tree))
2023 (repeated-redo-in-region
2024 (undo-tree-repeated-redo-in-region-p start end))
2025 undo-adjusted-markers ; `undo-elt-in-region' expects this
2026 fragment splice got-visible-elt redo-list elt)
2028 ;; --- inisitalisation ---
2030 ;; if this is a repeated redo-in-region, detach fragment below current
2032 (repeated-redo-in-region
2033 (when (setq fragment (car (undo-tree-node-next node)))
2034 (setf (undo-tree-node-previous fragment) nil
2035 (undo-tree-node-next node)
2036 (delq fragment (undo-tree-node-next node)))))
2037 ;; if this is a new redo-in-region, initial fragment is a copy of all
2038 ;; nodes below the current one in the active branch
2039 ((undo-tree-node-next node)
2040 (setq fragment (make-undo-tree-node nil nil)
2042 (while (setq node (nth (undo-tree-node-branch node)
2043 (undo-tree-node-next node)))
2044 (push (make-undo-tree-node
2046 (undo-copy-list (undo-tree-node-redo node)))
2047 (undo-tree-node-next splice))
2048 (setq splice (car (undo-tree-node-next splice))))
2049 (setq fragment (car (undo-tree-node-next fragment)))))
2052 ;; --- pull redo-in-region elements into branch ---
2053 ;; work down fragment, pulling out redo elements within region until
2054 ;; we've got one that redoes a visible change (insertion or deletion)
2055 (setq node fragment)
2057 (while (and (not got-visible-elt) node (undo-tree-node-redo node))
2058 ;; we cons a dummy nil element on the front of the changeset so that
2059 ;; we can conveniently remove the first (real) element from the
2060 ;; changeset if we need to; the leading nil is removed once we're
2061 ;; done with this changeset
2062 (setq redo-list (push nil (undo-tree-node-redo node))
2063 elt (cadr redo-list))
2066 ;; keep elements within region
2067 ((undo-elt-in-region elt start end)
2068 ;; set flag if kept element is visible (insertion or deletion)
2069 (when (and (consp elt)
2070 (or (stringp (car elt)) (integerp (car elt))))
2071 (setq got-visible-elt t))
2072 ;; adjust buffer positions in elements previously redone before
2073 ;; kept element, as kept element will now be redone first
2074 (undo-tree-adjust-elements-to-elt fragment elt t)
2075 ;; move kept element to redo-in-region changeset, adjusting its
2076 ;; buffer position as it will now be redone first
2077 (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1)))
2079 (setcdr redo-list (cddr redo-list)))
2081 ;; discard "was unmodified" elements
2082 ;; FIXME: deal properly with these
2083 ((and (consp elt) (eq (car elt) t))
2084 (setcdr redo-list (cddr redo-list)))
2086 ;; if element crosses region, we can't pull any more elements
2087 ((undo-elt-crosses-region elt start end)
2088 ;; if we've found a visible element, it must be earlier in
2089 ;; current node's changeset; stop pulling elements (null
2090 ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit)
2092 (setq redo-list nil)
2093 ;; if we haven't found a visible element yet, pulling
2094 ;; redo-in-region branch has failed
2095 (setq region-changeset nil)
2098 ;; if rejecting element, add its delta (if any) to the list
2100 (let ((delta (undo-delta elt)))
2101 (when (/= 0 (cdr delta))
2102 (setcdr d (list delta))
2104 (setq redo-list (cdr redo-list))))
2106 ;; process next element of current changeset
2107 (setq elt (cadr redo-list)))
2109 ;; if there are remaining elements in changeset, remove dummy nil
2111 (if (cadr (undo-tree-node-redo node))
2112 (pop (undo-tree-node-undo node))
2113 ;; otherwise, if we've kept all elements in changeset, discard
2115 (if (eq fragment node)
2116 (setq fragment (car (undo-tree-node-next fragment)))
2117 (undo-tree-snip-node node)))
2118 ;; process changeset from next node in fragment
2119 (setq node (car (undo-tree-node-next node)))))
2121 ;; pop dummy nil from front of `region-changeset'
2122 (pop region-changeset)
2125 ;; --- integrate branch into tree ---
2126 (setq node (undo-tree-current buffer-undo-tree))
2127 ;; if no redo-in-region elements were found, restore undo tree
2128 (if (null (car region-changeset))
2129 (when (and repeated-redo-in-region fragment)
2130 (push fragment (undo-tree-node-next node))
2131 (setf (undo-tree-node-branch node) 0
2132 (undo-tree-node-previous fragment) node)
2133 nil) ; return nil to indicate failure
2135 ;; otherwise, add redo-in-region node to top of fragment, and attach
2136 ;; it below current node
2139 (undo-tree-grow-backwards fragment nil region-changeset)
2140 (make-undo-tree-node nil nil region-changeset)))
2141 (push fragment (undo-tree-node-next node))
2142 (setf (undo-tree-node-branch node) 0
2143 (undo-tree-node-previous fragment) node)
2144 ;; update undo-tree size
2145 (unless repeated-redo-in-region
2146 (setq node fragment)
2148 (and (setq node (car (undo-tree-node-next node)))
2149 (incf (undo-tree-size buffer-undo-tree)
2150 (undo-list-byte-size
2151 (undo-tree-node-redo node)))))))
2152 (incf (undo-tree-size buffer-undo-tree)
2153 (undo-list-byte-size (undo-tree-node-redo fragment)))
2154 t) ; indicate undo-in-region branch was successfully pulled
2159 (defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below)
2160 "Adjust buffer positions of undo elements, starting at NODE's
2161 and going up the tree (or down the active branch if BELOW is
2162 non-nil) and through the nodes' undo elements until we reach
2163 UNDO-ELT. UNDO-ELT must appear somewhere in the undo changeset
2164 of either NODE itself or some node above it in the tree."
2165 (let ((delta (list (undo-delta undo-elt)))
2166 (undo-list (undo-tree-node-undo node)))
2167 ;; adjust elements until we reach UNDO-ELT
2168 (while (and (car undo-list)
2169 (not (eq (car undo-list) undo-elt)))
2171 (undo-tree-apply-deltas (car undo-list) delta -1))
2172 ;; move to next undo element in list, or to next node if we've run out
2174 (unless (car (setq undo-list (cdr undo-list)))
2176 (setq node (nth (undo-tree-node-branch node)
2177 (undo-tree-node-next node)))
2178 (setq node (undo-tree-node-previous node)))
2179 (setq undo-list (undo-tree-node-undo node))))))
2183 (defun undo-tree-apply-deltas (undo-elt deltas &optional sgn)
2184 ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN
2185 ;; (only useful value for SGN is -1).
2186 (let (position offset)
2187 (dolist (delta deltas)
2188 (setq position (car delta)
2189 offset (* (cdr delta) (or sgn 1)))
2192 ((integerp undo-elt)
2193 (when (>= undo-elt position)
2194 (setq undo-elt (- undo-elt offset))))
2195 ;; nil (or any other atom)
2197 ;; (TEXT . POSITION)
2198 ((stringp (car undo-elt))
2199 (let ((text-pos (abs (cdr undo-elt)))
2200 (point-at-end (< (cdr undo-elt) 0)))
2201 (if (>= text-pos position)
2202 (setcdr undo-elt (* (if point-at-end -1 1)
2203 (- text-pos offset))))))
2205 ((integerp (car undo-elt))
2206 (when (>= (car undo-elt) position)
2207 (setcar undo-elt (- (car undo-elt) offset))
2208 (setcdr undo-elt (- (cdr undo-elt) offset))))
2209 ;; (nil PROPERTY VALUE BEG . END)
2210 ((null (car undo-elt))
2211 (let ((tail (nthcdr 3 undo-elt)))
2212 (when (>= (car tail) position)
2213 (setcar tail (- (car tail) offset))
2214 (setcdr tail (- (cdr tail) offset)))))
2220 (defun undo-tree-repeated-undo-in-region-p (start end)
2221 ;; Return non-nil if undo-in-region between START and END is a repeated
2223 (let ((node (undo-tree-current buffer-undo-tree)))
2225 (nth (undo-tree-node-branch node) (undo-tree-node-next node)))
2226 (eq (undo-tree-node-undo-beginning node) start)
2227 (eq (undo-tree-node-undo-end node) end))))
2230 (defun undo-tree-repeated-redo-in-region-p (start end)
2231 ;; Return non-nil if undo-in-region between START and END is a repeated
2233 (let ((node (undo-tree-current buffer-undo-tree)))
2234 (and (eq (undo-tree-node-redo-beginning node) start)
2235 (eq (undo-tree-node-redo-end node) end))))
2238 ;; Return non-nil if undo-in-region between START and END is simply
2239 ;; reverting the last redo-in-region
2240 (defalias 'undo-tree-reverting-undo-in-region-p
2241 'undo-tree-repeated-undo-in-region-p)
2244 ;; Return non-nil if redo-in-region between START and END is simply
2245 ;; reverting the last undo-in-region
2246 (defalias 'undo-tree-reverting-redo-in-region-p
2247 'undo-tree-repeated-redo-in-region-p)
2252 ;;; =====================================================================
2253 ;;; Undo-tree commands
2256 (define-minor-mode undo-tree-mode
2257 "Toggle undo-tree mode.
2258 With no argument, this command toggles the mode.
2259 A positive prefix argument turns the mode on.
2260 A negative prefix argument turns it off.
2262 Undo-tree-mode replaces Emacs' standard undo feature with a more
2263 powerful yet easier to use version, that treats the undo history
2264 as what it is: a tree.
2266 The following keys are available in `undo-tree-mode':
2270 Within the undo-tree visualizer, the following keys are available:
2272 \\{undo-tree-visualizer-map}"
2275 undo-tree-mode-lighter ; lighter
2276 undo-tree-map ; keymap
2277 ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so
2278 ;; Emacs undo can work
2279 (unless undo-tree-mode
2280 (undo-list-rebuild-from-tree)
2281 (setq buffer-undo-tree nil)))
2284 (defun turn-on-undo-tree-mode (&optional print-message)
2285 "Enable `undo-tree-mode' in the current buffer, when appropriate.
2286 Some major modes implement their own undo system, which should
2287 not normally be overridden by `undo-tree-mode'. This command does
2288 not enable `undo-tree-mode' in such buffers. If you want to force
2289 `undo-tree-mode' to be enabled regardless, use (undo-tree-mode 1)
2292 The heuristic used to detect major modes in which
2293 `undo-tree-mode' should not be used is to check whether either
2294 the `undo' command has been remapped, or the default undo
2295 keybindings (C-/ and C-_) have been overridden somewhere other
2296 than in the global map. In addition, `undo-tree-mode' will not be
2297 enabled if the buffer's `major-mode' appears in
2298 `undo-tree-incompatible-major-modes'."
2300 (if (or (key-binding [remap undo])
2301 (undo-tree-overridden-undo-bindings-p)
2302 (memq major-mode undo-tree-incompatible-major-modes))
2304 (message "Buffer does not support undo-tree-mode;\
2305 undo-tree-mode NOT enabled"))
2306 (undo-tree-mode 1)))
2309 (defun undo-tree-overridden-undo-bindings-p ()
2310 "Returns t if default undo bindings are overridden, nil otherwise.
2311 Checks if either of the default undo key bindings (\"C-/\" or
2312 \"C-_\") are overridden in the current buffer by any keymap other
2313 than the global one. (So global redefinitions of the default undo
2314 key bindings do not count.)"
2315 (let ((binding1 (lookup-key (current-global-map) [?\C-/]))
2316 (binding2 (lookup-key (current-global-map) [?\C-_])))
2317 (global-set-key [?\C-/] 'undo)
2318 (global-set-key [?\C-_] 'undo)
2320 (or (and (key-binding [?\C-/])
2321 (not (eq (key-binding [?\C-/]) 'undo)))
2322 (and (key-binding [?\C-_])
2323 (not (eq (key-binding [?\C-_]) 'undo))))
2324 (global-set-key [?\C-/] binding1)
2325 (global-set-key [?\C-_] binding2))))
2329 (define-globalized-minor-mode global-undo-tree-mode
2330 undo-tree-mode turn-on-undo-tree-mode)
2334 (defun undo-tree-undo (&optional arg preserve-redo)
2336 Repeat this command to undo more changes.
2337 A numeric ARG serves as a repeat count.
2339 In Transient Mark mode when the mark is active, only undo changes
2340 within the current region. Similarly, when not in Transient Mark
2341 mode, just \\[universal-argument] as an argument limits undo to
2342 changes within the current region.
2344 A non-nil PRESERVE-REDO causes the existing redo record to be
2345 preserved, rather than replacing it with the new one generated by
2348 ;; throw error if undo is disabled in buffer
2349 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2351 (let ((undo-in-progress t)
2352 (undo-in-region (or (region-active-p) (and arg (not (numberp arg)))))
2354 ;; transfer entries accumulated in `buffer-undo-list' to
2355 ;; `buffer-undo-tree'
2356 (undo-list-transfer-to-tree)
2358 (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
2359 ;; check if at top of undo tree
2360 (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
2361 (error "No further undo information"))
2363 ;; if region is active, or a non-numeric prefix argument was supplied,
2364 ;; try to pull out a new branch of changes affecting the region
2365 (when (and undo-in-region
2366 (not (undo-tree-pull-undo-in-region-branch
2367 (region-beginning) (region-end))))
2368 (error "No further undo information for region"))
2370 ;; remove any GC'd elements from node's undo list
2371 (setq current (undo-tree-current buffer-undo-tree))
2372 (decf (undo-tree-size buffer-undo-tree)
2373 (undo-list-byte-size (undo-tree-node-undo current)))
2374 (setf (undo-tree-node-undo current)
2375 (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
2376 (incf (undo-tree-size buffer-undo-tree)
2377 (undo-list-byte-size (undo-tree-node-undo current)))
2378 ;; undo one record from undo tree
2379 (when undo-in-region
2380 (setq pos (set-marker (make-marker) (point)))
2381 (set-marker-insertion-type pos t))
2382 (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current)))
2385 ;; if preserving old redo record, discard new redo entries that
2386 ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
2387 ;; elements from node's redo list
2390 (undo-list-pop-changeset)
2391 (decf (undo-tree-size buffer-undo-tree)
2392 (undo-list-byte-size (undo-tree-node-redo current)))
2393 (setf (undo-tree-node-redo current)
2394 (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
2395 (incf (undo-tree-size buffer-undo-tree)
2396 (undo-list-byte-size (undo-tree-node-redo current))))
2397 ;; otherwise, record redo entries that `primitive-undo' has added to
2398 ;; `buffer-undo-list' in current node's redo record, replacing
2399 ;; existing entry if one already exists
2400 (when (undo-tree-node-redo current)
2401 (decf (undo-tree-size buffer-undo-tree)
2402 (undo-list-byte-size (undo-tree-node-redo current))))
2403 (setf (undo-tree-node-redo current)
2404 (undo-list-pop-changeset 'discard-pos))
2405 (incf (undo-tree-size buffer-undo-tree)
2406 (undo-list-byte-size (undo-tree-node-redo current))))
2408 ;; rewind current node and update timestamp
2409 (setf (undo-tree-current buffer-undo-tree)
2410 (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
2411 (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree))
2414 ;; if undoing-in-region, record current node, region and direction so we
2415 ;; can tell if undo-in-region is repeated, and re-activate mark if in
2416 ;; `transient-mark-mode'; if not, erase any leftover data
2417 (if (not undo-in-region)
2418 (undo-tree-node-clear-region-data current)
2420 ;; note: we deliberately want to store the region information in the
2421 ;; node *below* the now current one
2422 (setf (undo-tree-node-undo-beginning current) (region-beginning)
2423 (undo-tree-node-undo-end current) (region-end))
2424 (set-marker pos nil)))
2426 ;; undo deactivates mark unless undoing-in-region
2427 (setq deactivate-mark (not undo-in-region))
2428 ;; inform user if at branch point
2429 (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))
2433 (defun undo-tree-redo (&optional arg preserve-undo)
2434 "Redo changes. A numeric ARG serves as a repeat count.
2436 In Transient Mark mode when the mark is active, only redo changes
2437 within the current region. Similarly, when not in Transient Mark
2438 mode, just \\[universal-argument] as an argument limits redo to
2439 changes within the current region.
2441 A non-nil PRESERVE-UNDO causes the existing undo record to be
2442 preserved, rather than replacing it with the new one generated by
2445 ;; throw error if undo is disabled in buffer
2446 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2448 (let ((undo-in-progress t)
2449 (redo-in-region (or (region-active-p) (and arg (not (numberp arg)))))
2451 ;; transfer entries accumulated in `buffer-undo-list' to
2452 ;; `buffer-undo-tree'
2453 (undo-list-transfer-to-tree)
2455 (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
2456 ;; check if at bottom of undo tree
2457 (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree)))
2458 (error "No further redo information"))
2460 ;; if region is active, or a non-numeric prefix argument was supplied,
2461 ;; try to pull out a new branch of changes affecting the region
2462 (when (and redo-in-region
2463 (not (undo-tree-pull-redo-in-region-branch
2464 (region-beginning) (region-end))))
2465 (error "No further redo information for region"))
2467 ;; advance current node
2468 (setq current (undo-tree-current buffer-undo-tree)
2469 current (setf (undo-tree-current buffer-undo-tree)
2470 (nth (undo-tree-node-branch current)
2471 (undo-tree-node-next current))))
2472 ;; remove any GC'd elements from node's redo list
2473 (decf (undo-tree-size buffer-undo-tree)
2474 (undo-list-byte-size (undo-tree-node-redo current)))
2475 (setf (undo-tree-node-redo current)
2476 (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
2477 (incf (undo-tree-size buffer-undo-tree)
2478 (undo-list-byte-size (undo-tree-node-redo current)))
2479 ;; redo one record from undo tree
2480 (when redo-in-region
2481 (setq pos (set-marker (make-marker) (point)))
2482 (set-marker-insertion-type pos t))
2483 (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current)))
2486 ;; if preserving old undo record, discard new undo entries that
2487 ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
2488 ;; elements from node's redo list
2491 (undo-list-pop-changeset)
2492 (decf (undo-tree-size buffer-undo-tree)
2493 (undo-list-byte-size (undo-tree-node-undo current)))
2494 (setf (undo-tree-node-undo current)
2495 (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
2496 (incf (undo-tree-size buffer-undo-tree)
2497 (undo-list-byte-size (undo-tree-node-undo current))))
2498 ;; otherwise, record undo entries that `primitive-undo' has added to
2499 ;; `buffer-undo-list' in current node's undo record, replacing
2500 ;; existing entry if one already exists
2501 (when (undo-tree-node-undo current)
2502 (decf (undo-tree-size buffer-undo-tree)
2503 (undo-list-byte-size (undo-tree-node-undo current))))
2504 (setf (undo-tree-node-undo current)
2505 (undo-list-pop-changeset 'discard-pos))
2506 (incf (undo-tree-size buffer-undo-tree)
2507 (undo-list-byte-size (undo-tree-node-undo current))))
2510 (setf (undo-tree-node-timestamp current) (current-time))
2512 ;; if redoing-in-region, record current node, region and direction so we
2513 ;; can tell if redo-in-region is repeated, and re-activate mark if in
2514 ;; `transient-mark-mode'
2515 (if (not redo-in-region)
2516 (undo-tree-node-clear-region-data current)
2518 (setf (undo-tree-node-redo-beginning current) (region-beginning)
2519 (undo-tree-node-redo-end current) (region-end))
2520 (set-marker pos nil)))
2522 ;; redo deactivates the mark unless redoing-in-region
2523 (setq deactivate-mark (not redo-in-region))
2524 ;; inform user if at branch point
2525 (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))
2529 (defun undo-tree-switch-branch (branch)
2530 "Switch to a different BRANCH of the undo tree.
2531 This will affect which branch to descend when *redoing* changes
2532 using `undo-tree-redo'."
2533 (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg))
2534 (and (not (eq buffer-undo-list t))
2535 (or (undo-list-transfer-to-tree) t)
2536 (> (undo-tree-num-branches) 1)
2538 (format "Branch (0-%d): "
2539 (1- (undo-tree-num-branches))))))))
2540 ;; throw error if undo is disabled in buffer
2541 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2542 ;; sanity check branch number
2543 (when (<= (undo-tree-num-branches) 1) (error "Not at undo branch point"))
2544 (when (or (< branch 0) (> branch (1- (undo-tree-num-branches))))
2545 (error "Invalid branch number"))
2546 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2547 (undo-list-transfer-to-tree)
2549 (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
2553 (defun undo-tree-set (node)
2554 ;; Set buffer to state corresponding to NODE. Returns intersection point
2555 ;; between path back from current node and path back from selected NODE.
2556 (let ((path (make-hash-table :test 'eq))
2558 (puthash (undo-tree-root buffer-undo-tree) t path)
2559 ;; build list of nodes leading back from selected node to root, updating
2560 ;; branches as we go to point down to selected node
2563 (when (undo-tree-node-previous n)
2564 (setf (undo-tree-node-branch (undo-tree-node-previous n))
2566 n (undo-tree-node-next (undo-tree-node-previous n))))
2567 (setq n (undo-tree-node-previous n)))))
2568 ;; work backwards from current node until we intersect path back from
2570 (setq n (undo-tree-current buffer-undo-tree))
2571 (while (not (gethash n path))
2572 (setq n (undo-tree-node-previous n)))
2573 ;; ascend tree until intersection node
2574 (while (not (eq (undo-tree-current buffer-undo-tree) n))
2576 ;; descend tree until selected node
2577 (while (not (eq (undo-tree-current buffer-undo-tree) node))
2579 n)) ; return intersection node
2583 (defun undo-tree-save-state-to-register (register)
2584 "Store current undo-tree state to REGISTER.
2585 The saved state can be restored using
2586 `undo-tree-restore-state-from-register'.
2587 Argument is a character, naming the register."
2588 (interactive "cUndo-tree state to register: ")
2589 ;; throw error if undo is disabled in buffer
2590 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2591 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2592 (undo-list-transfer-to-tree)
2593 ;; save current node to REGISTER
2594 (set-register register (undo-tree-current buffer-undo-tree))
2595 ;; record REGISTER in current node, for visualizer
2596 (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree))
2601 (defun undo-tree-restore-state-from-register (register)
2602 "Restore undo-tree state from REGISTER.
2603 The state must be saved using `undo-tree-save-state-to-register'.
2604 Argument is a character, naming the register."
2605 (interactive "cRestore undo-tree state from register: ")
2606 ;; throw error if undo is disabled in buffer, or if register doesn't contain
2607 ;; an undo-tree node
2608 (let ((node (get-register register)))
2610 ((eq buffer-undo-list t)
2611 (error "No undo information in this buffer"))
2612 ((not (undo-tree-node-p node))
2613 (error "Register doesn't contain undo-tree state")))
2614 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2615 (undo-list-transfer-to-tree)
2616 ;; restore buffer state corresponding to saved node
2617 (undo-tree-set node)))
2622 ;;; =====================================================================
2623 ;;; Undo-tree visualizer
2625 (defun undo-tree-visualize ()
2626 "Visualize the current buffer's undo tree."
2629 ;; throw error if undo is disabled in buffer
2630 (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
2631 ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
2632 (undo-list-transfer-to-tree)
2633 ;; add hook to kill visualizer buffer if original buffer is changed
2634 (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t)
2635 ;; prepare *undo-tree* buffer, then draw tree in it
2636 (let ((undo-tree buffer-undo-tree)
2637 (buff (current-buffer))
2638 (display-buffer-mark-dedicated 'soft))
2639 (switch-to-buffer-other-window
2640 (get-buffer-create undo-tree-visualizer-buffer-name))
2641 (undo-tree-visualizer-mode)
2642 (setq undo-tree-visualizer-parent-buffer buff)
2643 (setq buffer-undo-tree undo-tree)
2644 (setq buffer-read-only nil)
2645 (undo-tree-draw-tree undo-tree)
2646 (setq buffer-read-only t)))
2649 (defun undo-tree-kill-visualizer (&rest dummy)
2650 ;; Kill visualizer. Added to `before-change-functions' hook of original
2651 ;; buffer when visualizer is invoked.
2652 (unless undo-in-progress
2654 (with-current-buffer undo-tree-visualizer-buffer-name
2655 (undo-tree-visualizer-quit)))))
2659 (defun undo-tree-draw-tree (undo-tree)
2660 ;; Draw UNDO-TREE in current buffer.
2662 (undo-tree-move-down 1) ; top margin
2663 (undo-tree-clear-visualizer-data undo-tree)
2664 (undo-tree-compute-widths undo-tree)
2665 (undo-tree-move-forward
2666 (max (/ (window-width) 2)
2667 (+ (undo-tree-node-char-lwidth (undo-tree-root undo-tree))
2668 ;; add space for left part of left-most time-stamp
2669 (if undo-tree-visualizer-timestamps 4 0)
2672 (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
2673 (stack (list (undo-tree-root undo-tree)))
2674 (n (undo-tree-root undo-tree)))
2675 ;; link root node to its representation in visualizer
2676 (unless (markerp (undo-tree-node-marker n))
2677 (setf (undo-tree-node-marker n) (make-marker))
2678 (set-marker-insertion-type (undo-tree-node-marker n) nil))
2679 (move-marker (undo-tree-node-marker n) (point))
2680 ;; draw nodes from stack until stack is empty
2682 (setq n (pop stack))
2683 (goto-char (undo-tree-node-marker n))
2684 (setq n (undo-tree-draw-subtree n nil))
2685 (setq stack (append stack n))))
2686 ;; highlight active branch
2687 (goto-char (undo-tree-node-marker (undo-tree-root undo-tree)))
2688 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
2689 (undo-tree-highlight-active-branch (undo-tree-root undo-tree)))
2690 ;; highlight current node
2691 (undo-tree-draw-node (undo-tree-current undo-tree) 'current))
2694 (defun undo-tree-highlight-active-branch (node)
2695 ;; Draw highlighted active branch below NODE in current buffer.
2696 (let ((stack (list node)))
2697 ;; link node to its representation in visualizer
2698 (unless (markerp (undo-tree-node-marker node))
2699 (setf (undo-tree-node-marker node) (make-marker))
2700 (set-marker-insertion-type (undo-tree-node-marker node) nil))
2701 (move-marker (undo-tree-node-marker node) (point))
2702 ;; draw active branch
2704 (setq node (pop stack))
2705 (goto-char (undo-tree-node-marker node))
2706 (setq node (undo-tree-draw-subtree node 'active))
2707 (setq stack (append stack node)))))
2710 (defun undo-tree-draw-node (node &optional current)
2711 ;; Draw symbol representing NODE in visualizer.
2712 (goto-char (undo-tree-node-marker node))
2713 (when undo-tree-visualizer-timestamps (backward-char 5))
2715 (let ((register (undo-tree-node-register node))
2717 (unless (and register (eq node (get-register register)))
2718 (setq register nil))
2719 ;; represent node by differentl symbols, depending on whether it's the
2720 ;; current node or is saved in a register
2723 (undo-tree-visualizer-timestamps
2724 (undo-tree-timestamp-to-string (undo-tree-node-timestamp node)))
2726 (register (char-to-string register))
2728 (when undo-tree-visualizer-timestamps
2730 (concat (if current "*" " ") node-string
2731 (if register (concat "(" (char-to-string register) ")")
2736 (let ((undo-tree-insert-face
2737 (cons 'undo-tree-visualizer-current-face
2738 (and (boundp 'undo-tree-insert-face)
2739 (or (and (consp undo-tree-insert-face)
2740 undo-tree-insert-face)
2741 (list undo-tree-insert-face))))))
2742 (undo-tree-insert node-string)))
2744 (let ((undo-tree-insert-face
2745 (cons 'undo-tree-visualizer-register-face
2746 (and (boundp 'undo-tree-insert-face)
2747 (or (and (consp undo-tree-insert-face)
2748 undo-tree-insert-face)
2749 (list undo-tree-insert-face))))))
2750 (undo-tree-insert node-string)))
2751 (t (undo-tree-insert node-string)))
2753 (backward-char (if undo-tree-visualizer-timestamps 7 1))
2754 (move-marker (undo-tree-node-marker node) (point))
2755 (put-text-property (- (point) (if undo-tree-visualizer-timestamps 3 0))
2756 (+ (point) (if undo-tree-visualizer-timestamps 5 1))
2757 'undo-tree-node node)))
2760 (defun undo-tree-draw-subtree (node &optional active-branch)
2761 ;; Draw subtree rooted at NODE. The subtree will start from point.
2762 ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE.
2763 ;; If TIMESTAP is non-nil, draw time-stamps instead of "o" at nodes.
2764 (let ((num-children (length (undo-tree-node-next node)))
2765 node-list pos trunk-pos n)
2767 (undo-tree-draw-node node)
2770 ;; if we're at a leaf node, we're done
2771 ((= num-children 0))
2773 ;; if node has only one child, draw it (not strictly necessary to deal
2774 ;; with this case separately, but as it's by far the most common case
2775 ;; this makes the code clearer and more efficient)
2777 (undo-tree-move-down 1)
2778 (undo-tree-insert ?|)
2780 (undo-tree-move-down 1)
2781 (undo-tree-insert ?|)
2783 (undo-tree-move-down 1)
2784 (setq n (car (undo-tree-node-next node)))
2785 ;; link next node to its representation in visualizer
2786 (unless (markerp (undo-tree-node-marker n))
2787 (setf (undo-tree-node-marker n) (make-marker))
2788 (set-marker-insertion-type (undo-tree-node-marker n) nil))
2789 (move-marker (undo-tree-node-marker n) (point))
2790 ;; add next node to list of nodes to draw next
2793 ;; if node had multiple children, draw branches
2795 (undo-tree-move-down 1)
2796 (undo-tree-insert ?|)
2798 (setq trunk-pos (point))
2801 (- (undo-tree-node-char-lwidth node)
2802 (undo-tree-node-char-lwidth
2803 (car (undo-tree-node-next node)))))
2805 (setq n (cons nil (undo-tree-node-next node)))
2806 (dotimes (i (/ num-children 2))
2808 (when (or (null active-branch)
2810 (nth (undo-tree-node-branch node)
2811 (undo-tree-node-next node))))
2812 (undo-tree-move-forward 2)
2813 (undo-tree-insert ?_ (- trunk-pos pos 2))
2815 (undo-tree-move-forward 1)
2816 (undo-tree-move-down 1)
2817 (undo-tree-insert ?/)
2819 (undo-tree-move-down 1)
2820 ;; link node to its representation in visualizer
2821 (unless (markerp (undo-tree-node-marker (car n)))
2822 (setf (undo-tree-node-marker (car n)) (make-marker))
2823 (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
2824 (move-marker (undo-tree-node-marker (car n)) (point))
2825 ;; add node to list of nodes to draw next
2826 (push (car n) node-list))
2828 (undo-tree-move-forward
2829 (+ (undo-tree-node-char-rwidth (car n))
2830 (undo-tree-node-char-lwidth (cadr n))
2831 undo-tree-visualizer-spacing 1))
2833 ;; middle subtree (only when number of children is odd)
2834 (when (= (mod num-children 2) 1)
2836 (when (or (null active-branch)
2838 (nth (undo-tree-node-branch node)
2839 (undo-tree-node-next node))))
2840 (undo-tree-move-down 1)
2841 (undo-tree-insert ?|)
2843 (undo-tree-move-down 1)
2844 ;; link node to its representation in visualizer
2845 (unless (markerp (undo-tree-node-marker (car n)))
2846 (setf (undo-tree-node-marker (car n)) (make-marker))
2847 (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
2848 (move-marker (undo-tree-node-marker (car n)) (point))
2849 ;; add node to list of nodes to draw next
2850 (push (car n) node-list))
2852 (undo-tree-move-forward
2853 (+ (undo-tree-node-char-rwidth (car n))
2854 (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
2855 undo-tree-visualizer-spacing 1))
2859 (dotimes (i (/ num-children 2))
2861 (when (or (null active-branch)
2863 (nth (undo-tree-node-branch node)
2864 (undo-tree-node-next node))))
2865 (goto-char trunk-pos)
2866 (undo-tree-insert ?_ (- pos trunk-pos 1))
2869 (undo-tree-move-down 1)
2870 (undo-tree-insert ?\\)
2871 (undo-tree-move-down 1)
2872 ;; link node to its representation in visualizer
2873 (unless (markerp (undo-tree-node-marker (car n)))
2874 (setf (undo-tree-node-marker (car n)) (make-marker))
2875 (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
2876 (move-marker (undo-tree-node-marker (car n)) (point))
2877 ;; add node to list of nodes to draw next
2878 (push (car n) node-list))
2881 (undo-tree-move-forward
2882 (+ (undo-tree-node-char-rwidth (car n))
2883 (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
2884 undo-tree-visualizer-spacing 1))
2885 (setq pos (point))))
2887 ;; return list of nodes to draw next
2888 (nreverse node-list)))
2892 (defun undo-tree-node-char-lwidth (node)
2893 ;; Return left-width of NODE measured in characters.
2894 (if (= (length (undo-tree-node-next node)) 0) 0
2895 (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node))
2896 (if (= (undo-tree-node-cwidth node) 0)
2897 (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
2900 (defun undo-tree-node-char-rwidth (node)
2901 ;; Return right-width of NODE measured in characters.
2902 (if (= (length (undo-tree-node-next node)) 0) 0
2903 (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node))
2904 (if (= (undo-tree-node-cwidth node) 0)
2905 (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
2908 (defun undo-tree-insert (str &optional arg)
2909 ;; Insert character or string STR ARG times, overwriting, and using
2910 ;; `undo-tree-insert-face'.
2911 (unless arg (setq arg 1))
2912 (when (characterp str)
2913 (setq str (make-string arg str))
2915 (dotimes (i arg) (insert str))
2916 (setq arg (* arg (length str)))
2917 (undo-tree-move-forward arg)
2918 ;; make sure mark isn't active, otherwise `backward-delete-char' might
2919 ;; delete region instead of single char if transient-mark-mode is enabled
2920 (setq mark-active nil)
2921 (backward-delete-char arg)
2922 (when (boundp 'undo-tree-insert-face)
2923 (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face)))
2926 (defun undo-tree-move-down (&optional arg)
2927 ;; Move down, extending buffer if necessary.
2928 (let ((row (line-number-at-pos))
2929 (col (current-column))
2931 (unless arg (setq arg 1))
2933 (setq line (line-number-at-pos))
2934 ;; if buffer doesn't have enough lines, add some
2935 (when (/= line (+ row arg))
2936 (insert (make-string (- arg (- line row)) ?\n)))
2937 (undo-tree-move-forward col)))
2940 (defun undo-tree-move-forward (&optional arg)
2941 ;; Move forward, extending buffer if necessary.
2942 (unless arg (setq arg 1))
2943 (let ((n (- (line-end-position) (point))))
2947 (insert (make-string (- arg n) ? )))))
2950 (defun undo-tree-timestamp-to-string (timestamp)
2951 ;; Convert TIMESTAMP to hh:mm:ss string.
2952 (let ((time (decode-time timestamp)))
2953 (format "%02d:%02d:%02d" (nth 2 time) (nth 1 time) (nth 0 time))))
2958 ;;; =====================================================================
2959 ;;; Visualizer mode commands
2961 (defun undo-tree-visualizer-mode ()
2962 "Major mode used in undo-tree visualizer.
2964 The undo-tree visualizer can only be invoked from a buffer in
2965 which `undo-tree-mode' is enabled. The visualizer displays the
2966 undo history tree graphically, and allows you to browse around
2967 the undo history, undoing or redoing the corresponding changes in
2970 Within the undo-tree visualizer, the following keys are available:
2972 \\{undo-tree-visualizer-map}"
2974 (setq major-mode 'undo-tree-visualizer-mode)
2975 (setq mode-name "undo-tree-visualizer-mode")
2976 (use-local-map undo-tree-visualizer-map)
2977 (setq truncate-lines t)
2978 (setq cursor-type nil)
2979 (setq buffer-read-only t))
2983 (defun undo-tree-visualize-undo (&optional arg)
2984 "Undo changes. A numeric ARG serves as a repeat count."
2986 (setq buffer-read-only nil)
2987 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
2988 (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
2989 (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
2992 (undo-tree-undo arg)
2993 (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
2994 (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
2995 (setq buffer-read-only t)))
2998 (defun undo-tree-visualize-redo (&optional arg)
2999 "Redo changes. A numeric ARG serves as a repeat count."
3001 (setq buffer-read-only nil)
3002 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3003 (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
3004 (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
3007 (undo-tree-redo arg)
3008 (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
3009 (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3010 (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
3011 (setq buffer-read-only t)))
3014 (defun undo-tree-visualize-switch-branch-right (arg)
3015 "Switch to next branch of the undo tree.
3016 This will affect which branch to descend when *redoing* changes
3017 using `undo-tree-redo' or `undo-tree-visualizer-redo'."
3019 ;; un-highlight old active branch below current node
3020 (setq buffer-read-only nil)
3021 (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3022 (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face))
3023 (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
3025 (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree))))
3026 (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
3028 ((>= (+ branch arg) (undo-tree-num-branches))
3029 (1- (undo-tree-num-branches)))
3030 ((<= (+ branch arg) 0) 0)
3031 (t (+ branch arg))))
3032 ;; highlight new active branch below current node
3033 (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
3034 (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
3035 (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
3036 ;; re-highlight current node
3037 (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
3038 (setq buffer-read-only t)))
3041 (defun undo-tree-visualize-switch-branch-left (arg)
3042 "Switch to previous branch of the undo tree.
3043 This will affect which branch to descend when *redoing* changes
3044 using `undo-tree-redo' or `undo-tree-visualizer-redo'."
3046 (undo-tree-visualize-switch-branch-right (- arg)))
3049 (defun undo-tree-visualizer-quit ()
3050 "Quit the undo-tree visualizer."
3052 (undo-tree-clear-visualizer-data buffer-undo-tree)
3053 ;; remove kill visualizer hook from parent buffer
3055 (with-current-buffer undo-tree-visualizer-parent-buffer
3056 (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t))
3057 (let ((parent undo-tree-visualizer-parent-buffer)
3060 (if (setq window (get-buffer-window parent))
3061 (select-window window)
3062 (switch-to-buffer parent)))))
3065 (defun undo-tree-visualizer-set (&optional pos)
3066 "Set buffer to state corresponding to undo tree node
3067 at POS, or point if POS is nil."
3069 (unless pos (setq pos (point)))
3070 (let ((node (get-text-property pos 'undo-tree-node)))
3072 ;; set parent buffer to state corresponding to node at POS
3073 (set-buffer undo-tree-visualizer-parent-buffer)
3074 (undo-tree-set node)
3075 (set-buffer undo-tree-visualizer-buffer-name)
3076 (setq buffer-read-only nil)
3077 ;; re-draw undo tree
3078 (undo-tree-draw-tree buffer-undo-tree)
3079 (setq buffer-read-only t))))
3082 (defun undo-tree-visualizer-mouse-set (pos)
3083 "Set buffer to state corresponding to undo tree node
3084 at mouse event POS."
3086 (undo-tree-visualizer-set (event-start (nth 1 pos))))
3089 (defun undo-tree-visualizer-toggle-timestamps ()
3090 "Toggle display of time-stamps."
3092 (setq undo-tree-visualizer-spacing
3093 (if (setq undo-tree-visualizer-timestamps
3094 (not undo-tree-visualizer-timestamps))
3095 ;; need sufficient space if displaying timestamps
3096 (max 13 (default-value 'undo-tree-visualizer-spacing))
3097 (default-value 'undo-tree-visualizer-spacing)))
3099 (setq buffer-read-only nil)
3100 (undo-tree-draw-tree buffer-undo-tree)
3101 (setq buffer-read-only t))
3104 (defun undo-tree-visualizer-scroll-left (&optional arg)
3106 (scroll-right (or arg 1) t))
3109 (defun undo-tree-visualizer-scroll-right (&optional arg)
3111 (scroll-left (or arg 1) t))
3116 ;;; =====================================================================
3117 ;;; Visualizer selection mode
3119 (defun undo-tree-visualizer-selection-mode ()
3120 "Major mode used to select nodes in undo-tree visualizer."
3122 (setq major-mode 'undo-tree-visualizer-selection-mode)
3123 (setq mode-name "undo-tree-visualizer-selection-mode")
3124 (use-local-map undo-tree-visualizer-selection-map)
3125 (setq cursor-type 'box))
3128 (defun undo-tree-visualizer-select-previous (&optional arg)
3129 "Move to previous node."
3131 (let ((node (get-text-property (point) 'undo-tree-node)))
3134 (unless (undo-tree-node-previous node) (throw 'top t))
3135 (setq node (undo-tree-node-previous node))))
3136 (goto-char (undo-tree-node-marker node))))
3139 (defun undo-tree-visualizer-select-next (&optional arg)
3140 "Move to next node."
3142 (let ((node (get-text-property (point) 'undo-tree-node)))
3145 (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node))
3148 (nth (undo-tree-node-branch node) (undo-tree-node-next node)))))
3149 (goto-char (undo-tree-node-marker node))))
3152 (defun undo-tree-visualizer-select-right (&optional arg)
3153 "Move right to a sibling node."
3156 (end (line-end-position))
3162 (setq node (get-text-property (point) 'undo-tree-node))
3163 (when (= (point) end) (throw 'end t)))))
3164 (goto-char (if node (undo-tree-node-marker node) pos))))
3167 (defun undo-tree-visualizer-select-left (&optional arg)
3168 "Move left to a sibling node."
3171 (beg (line-beginning-position))
3177 (setq node (get-text-property (point) 'undo-tree-node))
3178 (when (= (point) beg) (throw 'beg t)))))
3179 (goto-char (if node (undo-tree-node-marker node) pos))))
3183 (provide 'undo-tree)
3185 ;;; undo-tree.el ends here