multiple changes
authorJoerg Jaspert <joerg@debian.org>
Mon, 22 Apr 2013 06:05:09 +0000 (08:05 +0200)
committerJoerg Jaspert <joerg@debian.org>
Mon, 22 Apr 2013 06:05:09 +0000 (08:05 +0200)
- tab width is 8, not 4. we dont use them, but we should display them
  like the rest of the world
- blinking cursor is off
- my kill-line function now respects indentation
- even in org-mode
- changes to window nav. windmode, C-x O
- sudo-edit function from prelude - C-x C-r and root edits the file
- fringes are smaller
- save history
- use undo-tree, diminish, volatile-highlights
- some lisp things

.emacs.d/config/customized.el
.emacs.d/config/emacs.org
elisp/local/ganneff.el
elisp/local/loaddefs.el
elisp/local/paredit.el [new file with mode: 0644]
elisp/local/rainbow-mode.el [new file with mode: 0644]
elisp/local/undo-tree.el [new file with mode: 0644]
elisp/local/volatile-highlights.el [new file with mode: 0644]

index b8d86bf..92f4011 100644 (file)
@@ -18,7 +18,7 @@
  '(randomsig-static-string "bye, Joerg
 ")
  '(sieve-manage-default-port 4190)
- '(tab-width 4)
+ '(tab-width 8)
  '(text-mode-hook (quote (turn-on-auto-fill text-mode-hook-identify)))
  '(tool-bar-mode nil nil (tool-bar)))
 
index 09ae0c8..02a746d 100644 (file)
@@ -253,11 +253,6 @@ backups. See [[info:emacs#Auto%20Save%20Control][info:emacs#Auto Save Control]]
 (setq auto-save-timeout   60)
 #+END_SRC
 
-I really dislike `kill-line` (key: C-k) to kill from the point to the end of line.
-#+BEGIN_SRC emacs-lisp
-(setq kill-whole-line t)
-#+END_SRC
-
 Set my full name and my default mail address - for whatever wants to use
 it later. Also, I am using gnus.
 #+BEGIN_SRC emacs-lisp
@@ -331,6 +326,12 @@ For them to work even then, we have to do two things.
 2. We have to disable the toolbar using the customize interface, so you
    can find that in the [[id:0102208d-fdf6-4928-9e40-7e341bd3aa3a][Customized variables]] section.
 
+*** Turn the cursor blinking off
+[2013-04-21 So 20:54]
+#+BEGIN_SRC emacs-lisp
+(blink-cursor-mode -1)
+#+END_SRC
+
 *** Load our theme
 Actually not ours, it is from Julien Danjou, see [[http://git.naquadah.org/?p%3Dnaquadah-theme.git%3Ba%3Dsummary][git.naquadah.org Git -
 naquadah-theme.git]]
@@ -438,10 +439,24 @@ me. Lazyness++.
   "Kill this entire line (including newline), regardless of where point is within the line."
   (interactive)
   (beginning-of-line)
-  (kill-line))
+  (kill-line)
+  (back-to-indentation))
 
 (global-unset-key [(control k)])
 (global-set-key [(control k)] 'kill-entire-line)
+(global-set-key [remap kill-whole-line] 'kill-entire-line)
+#+END_SRC
+
+And the same is true when I'm in org-mode, which has an own kill function...
+(the keybinding happens later, after org-mode is loaded fully)
+#+BEGIN_SRC emacs-lisp
+(defun jj-org-kill-line (&optional arg)
+  "Kill the entire line, regardless of where point is within the line, org-mode-version"
+  (interactive "P")
+  (beginning-of-line)
+  (org-kill-line arg)
+  (back-to-indentation)
+  )
 #+END_SRC
 
 I really hate tabs, so I don't want any indentation to try using them.
@@ -510,6 +525,18 @@ Easier undo, and i don't need suspend-frame
 (global-set-key (kbd "C-z") 'undo)
 #+END_SRC
 
+Window switching, go backwards. (C-x o goes to the next window)
+#+BEGIN_SRC emacs-lisp
+(global-set-key (kbd "C-x O") (lambda ()
+                                (interactive)
+                                (other-window -1)))
+#+END_SRC
+
+Edit file as root
+#+BEGIN_SRC emacs-lisp
+  (global-set-key (kbd "C-x C-r") 'prelude-sudo-edit)
+#+END_SRC
+
 **** Overwrite mode
 Usually you can press the *Ins*ert key, to get into overwrite mode. I
 don't like that, have broken much with it and so just forbid it by
@@ -608,7 +635,6 @@ jump half-windows?
 
 *** Copy/Paste with X
 [2013-04-09 Di 23:31]
-#+BEGIN_SRC emacs-lisp
 The default how emacs handles cutting/pasting with the primary selection
 changed in emacs24. I am used to the old way, so get it.
 #+BEGIN_SRC emacs-lisp
@@ -622,6 +648,14 @@ changed in emacs24. I am used to the old way, so get it.
 
 #+END_SRC
 
+*** fringe
+[2013-04-21 So 20:56]
+Make the fringe (gutter) smaller, the argument is a width in pixels (the default is 8)
+#+BEGIN_SRC emacs-lisp
+(if (fboundp 'fringe-mode)
+    (fringe-mode 4))
+#+END_SRC
+
 ** Miscellaneous stuff
 #+BEGIN_SRC emacs-lisp
 (setq backup-by-copying t)
@@ -857,6 +891,7 @@ Always have unique buffernames. See [[http://www.gnu.org/software/emacs/manual/h
 (require 'uniquify)
 (setq uniquify-buffer-name-style 'post-forward)
 (setq uniquify-after-kill-buffer-p t)
+(setq uniquify-ignore-buffers-re "^\\*")
 #+END_SRC
 
 ** abbrev
@@ -1137,6 +1172,9 @@ Instead of default /html-mode/ I use /html-helper-mode/.
 (global-set-key (kbd "C-s-<f12>") 'bh/save-then-publish)
 (global-set-key (kbd "C-M-r") 'org-capture)
 (global-set-key (kbd "C-c r") 'org-capture)
+
+(define-key org-mode-map [(control k)] 'jj-org-kill-line)
+
 #+end_src
 
 Speed commands enable single-letter commands in Org-mode files when
@@ -1791,6 +1829,21 @@ Store at which point I have been in files.
 (setq-default save-place t)
 (setq save-place-file "~/.emacs.d/saved-places")
 #+END_SRC
+** savehist
+[2013-04-21 So 20:25]
+Save a bit of history
+#+BEGIN_SRC emacs-lisp
+(require 'savehist)
+(setq savehist-additional-variables
+      ;; search entries
+      '(search ring regexp-search-ring)
+      ;; save every minute
+      savehist-autosave-interval 60
+      ;; keep the home clean
+      savehist-file (expand-file-name "savehist" "~/.emacs.d"))
+(savehist-mode +1)
+#+END_SRC
+
 ** easypg
 EasyPG is a GnuPG interface for Emacs.
 
@@ -1895,6 +1948,101 @@ yourself in the code, and tell which statements are at the same depth.
 (when (require 'rainbow-delimiters nil 'noerror) 
   (global-rainbow-delimiters-mode))
 #+END_SRC
+** undo-tree
+[2013-04-21 So 11:07]
+Emacs undo is pretty powerful - but can also be confusing. There are
+tons of modes available to change it, even downgrade it to the very
+crappy ways one usually knows from other systems which lose
+information. undo-tree is different - it helps keeping you sane while
+keeping the full power of emacs undo/redo.
+#+BEGIN_SRC emacs-lisp
+(require 'undo-tree)
+(global-undo-tree-mode)
+(diminish 'undo-tree-mode)
+#+END_SRC
+
+Additionally I would like to keep the region active should I undo
+while I have one.
+
+#+BEGIN_SRC emacs-lisp
+;; Keep region when undoing in region
+(defadvice undo-tree-undo (around keep-region activate)
+  (if (use-region-p)
+      (let ((m (set-marker (make-marker) (mark)))
+            (p (set-marker (make-marker) (point))))
+        ad-do-it
+        (goto-char p)
+        (set-mark m)
+        (set-marker p nil)
+        (set-marker m nil))
+    ad-do-it))
+#+END_SRC
+** windmove
+[2013-04-21 So 20:27]
+Use shift + arrow keys to switch between visible buffers
+#+BEGIN_SRC emacs-lisp
+(require 'windmove)
+(windmove-default-keybindings)
+#+END_SRC
+** volatile highlights
+[2013-04-21 So 20:31]
+VolatileHighlights highlights changes to the buffer caused by commands
+such as ‘undo’, ‘yank’/’yank-pop’, etc. The highlight disappears at the
+next command. The highlighting gives useful visual feedback for what
+your operation actually changed in the buffer.
+#+BEGIN_SRC emacs-lisp
+(require 'volatile-highlights)
+(volatile-highlights-mode t)
+(diminish 'volatile-highlights-mode)
+#+END_SRC
+** ediff
+[2013-04-21 So 20:36]
+;; ediff - don't start another frame
+#+BEGIN_SRC elisp
+  (require 'ediff)
+  (setq ediff-window-setup-function 'ediff-setup-windows-plain)
+#+END_SRC
+** re-builder
+Saner regex syntax
+#+BEGIN_SRC emacs-lisp
+(require 're-builder)
+(setq reb-re-syntax 'string)
+#+END_SRC
+
+[2013-04-21 So 20:39]
+
+** magit related
+[2013-04-21 So 20:48]
+#+BEGIN_SRC emacs-lisp
+(global-set-key (kbd "C-x g") 'magit-status)
+#+END_SRC
+
+** lisp editing stuff
+[2013-04-21 So 21:00]
+I'm not doing much of it, except for my emacs and gnus configs, but
+then I like it nice too...
+#+BEGIN_SRC emacs-lisp
+    (define-key read-expression-map (kbd "TAB") 'lisp-complete-symbol)
+    (require 'paredit)
+    (setq lisp-coding-hook 'lisp-coding-defaults)
+      (setq interactive-lisp-coding-hook 'interactive-lisp-coding-defaults)
+    
+    (eval-after-load "paredit"
+      '(diminish 'paredit-mode " π"))
+    
+  (setq prelude-emacs-lisp-mode-hook 'prelude-emacs-lisp-mode-defaults)
+  (add-hook 'emacs-lisp-mode-hook (lambda ()
+                                    (run-hooks 'prelude-emacs-lisp-mode-hook)))
+  
+  (define-key emacs-lisp-mode-map (kbd "M-.") 'find-function-at-point)
+  
+  (eval-after-load "elisp-slime-nav"
+    '(diminish 'elisp-slime-nav-mode))
+  (eval-after-load "rainbow-mode"
+    '(diminish 'rainbow-mode))
+  (eval-after-load "eldoc"
+    '(diminish 'eldoc-mode))
+#+END_SRC
 * Customized variables
 :PROPERTIES:
 :ID: 0102208d-fdf6-4928-9e40-7e341bd3aa3a
index 09e208e..40df55a 100644 (file)
@@ -746,7 +746,7 @@ so change the default 'F' binding in the agenda to allow both"
     (skip-syntax-backward "w_")
     (goto-char
      (if (re-search-backward (concat "\\_<" (current-word) "\\_>") nil t)
-        (match-beginning 0)
+     (match-beginning 0)
        cur))))
 
 ;;;###autoload
@@ -757,7 +757,7 @@ so change the default 'F' binding in the agenda to allow both"
     (skip-syntax-forward "w_")
     (goto-char
      (if (re-search-forward (concat "\\_<" (current-word) "\\_>") nil t)
-        (match-beginning 0)
+     (match-beginning 0)
        cur))))
 
 ;;;###autoload
@@ -856,6 +856,51 @@ so change the default 'F' binding in the agenda to allow both"
   (forward-line -1)
   (indent-according-to-mode))
 
+;;;###autoload
+(defun jj-untabify-buffer ()
+  "Get rid of all tabs"
+  (interactive)
+  (untabify (point-min) (point-max)))
+
+;;;###autoload
+(defun prelude-sudo-edit (&optional arg)
+  "Edit currently visited file as root.
+
+With a prefix ARG prompt for a file to visit.
+Will also prompt for a file to visit if current
+buffer is not visiting a file."
+  (interactive "P")
+  (if (or arg (not buffer-file-name))
+      (find-file (concat "/sudo:root@localhost:"
+                         (icicle-find-file-of-content)))
+    (find-alternate-file (concat "/sudo:root@localhost:" buffer-file-name))))
+
+;; a great lisp coding hook
+;;;###autoload
+(defun lisp-coding-defaults ()
+  (paredit-mode +1)
+  (rainbow-delimiters-mode +1))
+;;;###autoload
+(defun interactive-lisp-coding-defaults ()
+  (paredit-mode +1)
+  (rainbow-delimiters-mode +1)
+  (whitespace-mode -1))
+;;;###autoload
+(defun prelude-remove-elc-on-save ()
+  "If you're saving an elisp file, likely the .elc is no longer valid."
+  (make-local-variable 'after-save-hook)
+  (add-hook 'after-save-hook
+            (lambda ()
+              (if (file-exists-p (concat buffer-file-name "c"))
+                  (delete-file (concat buffer-file-name "c"))))))
+
+;;;###autoload
+(defun prelude-emacs-lisp-mode-defaults ()
+  (run-hooks 'lisp-coding-hook)
+  (turn-on-eldoc-mode)
+  (prelude-remove-elc-on-save)
+  (rainbow-mode +1)
+  (setq mode-name "EL"))
 
 (provide 'ganneff)
 
index cdab72e..328441d 100644 (file)
@@ -1573,7 +1573,9 @@ VERBOSE argument is non-nil, display a confirmation message.
 
 ;;;***
 \f
-;;;### (autoloads (move-line-down move-line-up revert-all-buffers
+;;;### (autoloads (prelude-emacs-lisp-mode-defaults prelude-remove-elc-on-save
+;;;;;;  interactive-lisp-coding-defaults lisp-coding-defaults prelude-sudo-edit
+;;;;;;  jj-untabify-buffer move-line-down move-line-up revert-all-buffers
 ;;;;;;  org-mycal-export mycal-export-limit org-mycal-export-limit
 ;;;;;;  my-c-return epa-dired-mode-hook sacha/decrease-font-size
 ;;;;;;  sacha/increase-font-size sacha/search-word-forward sacha/search-word-backward
@@ -1598,7 +1600,7 @@ VERBOSE argument is non-nil, display a confirmation message.
 ;;;;;;  bh/is-due-deadline bh/is-not-scheduled-or-deadline bh/agenda-sort
 ;;;;;;  bh/agenda-sort-test-num bh/agenda-sort-test bh/verify-refile-target
 ;;;;;;  bh/show-org-agenda ido-disable-line-trucation my-dired-init)
-;;;;;;  "ganneff" "ganneff.el" (20835 4052 801261 487000))
+;;;;;;  "ganneff" "ganneff.el" (20852 15577 271364 888000))
 ;;; Generated autoloads from ganneff.el
 
 (autoload 'my-dired-init "ganneff" "\
@@ -1984,6 +1986,40 @@ Move down the current line.
 
 \(fn)" t nil)
 
+(autoload 'jj-untabify-buffer "ganneff" "\
+Get rid of all tabs
+
+\(fn)" t nil)
+
+(autoload 'prelude-sudo-edit "ganneff" "\
+Edit currently visited file as root.
+
+With a prefix ARG prompt for a file to visit.
+Will also prompt for a file to visit if current
+buffer is not visiting a file.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'lisp-coding-defaults "ganneff" "\
+
+
+\(fn)" nil nil)
+
+(autoload 'interactive-lisp-coding-defaults "ganneff" "\
+
+
+\(fn)" nil nil)
+
+(autoload 'prelude-remove-elc-on-save "ganneff" "\
+If you're saving an elisp file, likely the .elc is no longer valid.
+
+\(fn)" nil nil)
+
+(autoload 'prelude-emacs-lisp-mode-defaults "ganneff" "\
+
+
+\(fn)" nil nil)
+
 ;;;***
 \f
 ;;;### (autoloads (sign-or-crypt gnus-user-format-function-topic-line
@@ -1998,7 +2034,7 @@ Move down the current line.
 ;;;;;;  nnimap-message-count-cache-set nnimap-message-count-cache-get
 ;;;;;;  nnimap-message-count-cache-clear gnus-user-format-function-x
 ;;;;;;  gnus-user-format-function-t gnus-nnimap-count-format) "ganneff-gnus"
-;;;;;;  "ganneff-gnus.el" (20778 36657 527957 567000))
+;;;;;;  "ganneff-gnus.el" (20840 22532 168188 958000))
 ;;; Generated autoloads from ganneff-gnus.el
 
 (autoload 'gnus-nnimap-count-format "ganneff-gnus" "\
@@ -2950,6 +2986,23 @@ If LOCATION is not set, use org-google-weather-location.
 
 ;;;***
 \f
+;;;### (autoloads (paredit-mode) "paredit" "paredit.el" (20852 14113
+;;;;;;  540106 637000))
+;;; Generated autoloads from paredit.el
+
+(autoload 'paredit-mode "paredit" "\
+Minor mode for pseudo-structurally editing Lisp code.
+With a prefix argument, enable Paredit Mode even if there are
+  unbalanced parentheses in the buffer.
+Paredit behaves badly if parentheses are unbalanced, so exercise
+  caution when forcing Paredit Mode to be enabled, and consider
+  fixing unbalanced parentheses instead.
+\\<paredit-mode-map>
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
 ;;;### (autoloads (global-rainbow-delimiters-mode rainbow-delimiters-mode-disable
 ;;;;;;  rainbow-delimiters-mode-enable rainbow-delimiters-mode) "rainbow-delimiters"
 ;;;;;;  "rainbow-delimiters.el" (20836 35883 0 0))
@@ -2993,6 +3046,18 @@ See `rainbow-delimiters-mode' for more information on Rainbow-Delimiters mode.
 
 ;;;***
 \f
+;;;### (autoloads (rainbow-mode) "rainbow-mode" "rainbow-mode.el"
+;;;;;;  (20852 15370 82337 493000))
+;;; Generated autoloads from rainbow-mode.el
+
+(autoload 'rainbow-mode "rainbow-mode" "\
+Colorize strings that represent colors.
+This will fontify with colors the string like \"#aabbcc\" or \"blue\".
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
 ;;;### (autoloads (register-list) "register-list" "register-list.el"
 ;;;;;;  (18388 31493 0 0))
 ;;; Generated autoloads from register-list.el
@@ -3037,6 +3102,53 @@ Turn off Screen Lines minor mode for the current buffer.
 
 ;;;***
 \f
+;;;### (autoloads (global-undo-tree-mode undo-tree-mode) "undo-tree"
+;;;;;;  "undo-tree.el" (20851 43855 216847 15000))
+;;; Generated autoloads from undo-tree.el
+
+(autoload 'undo-tree-mode "undo-tree" "\
+Toggle undo-tree mode.
+With no argument, this command toggles the mode.
+A positive prefix argument turns the mode on.
+A negative prefix argument turns it off.
+
+Undo-tree-mode replaces Emacs' standard undo feature with a more
+powerful yet easier to use version, that treats the undo history
+as what it is: a tree.
+
+The following keys are available in `undo-tree-mode':
+
+  \\{undo-tree-map}
+
+Within the undo-tree visualizer, the following keys are available:
+
+  \\{undo-tree-visualizer-map}
+
+\(fn &optional ARG)" t nil)
+
+(defvar global-undo-tree-mode nil "\
+Non-nil if Global-Undo-Tree mode is enabled.
+See the command `global-undo-tree-mode' for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `global-undo-tree-mode'.")
+
+(custom-autoload 'global-undo-tree-mode "undo-tree" nil)
+
+(autoload 'global-undo-tree-mode "undo-tree" "\
+Toggle Undo-Tree mode in all buffers.
+With prefix ARG, enable Global-Undo-Tree mode if ARG is positive;
+otherwise, disable it.  If called from Lisp, enable the mode if
+ARG is omitted or nil.
+
+Undo-Tree mode is enabled in all buffers where
+`turn-on-undo-tree-mode' would do it.
+See `undo-tree-mode' for more information on Undo-Tree mode.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
 ;;;### (autoloads (update-autoloads-for-file-in-package-area update-autoloads-in-package-area)
 ;;;;;;  "update-autoloads" "update-autoloads.el" (20371 4810 134211
 ;;;;;;  154000))
@@ -3137,8 +3249,8 @@ Durations are measured in hours.  If invoked non-interactively (i.e., \"emacs
 ;;;### (autoloads nil nil ("beamer.el" "bind-key.el" "buildd-gnus.el"
 ;;;;;;  "color-theme.el" "crypt++.el" "dash.el" "ldap-mode.el" "manoj-colors.el"
 ;;;;;;  "mingus-stays-home.el" "mingus.el" "moinmoin-mode.el" "naquadah-theme.el"
-;;;;;;  "nnir.el" "nntodo.el" "randomsig.el" "typing.el" "use-package.el")
-;;;;;;  (20836 36631 376648 4000))
+;;;;;;  "nnir.el" "nntodo.el" "randomsig.el" "typing.el" "use-package.el"
+;;;;;;  "volatile-highlights.el") (20852 15604 904716 29000))
 
 ;;;***
 \f
diff --git a/elisp/local/paredit.el b/elisp/local/paredit.el
new file mode 100644 (file)
index 0000000..c35ba66
--- /dev/null
@@ -0,0 +1,2625 @@
+;;; paredit.el --- minor mode for editing parentheses  -*- Mode: Emacs-Lisp -*-
+
+;; Copyright (C) 2005--2011 Taylor R. Campbell
+
+;; Author: Taylor R. Campbell
+;; Version: 23
+;; Created: 2005-07-31
+;; Keywords: lisp
+
+;; Paredit is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Paredit is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with paredit.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; This file is permanently stored at
+;;;   <http://mumble.net/~campbell/emacs/paredit-23.el>.
+;;;
+;;; The currently released version of paredit is available at
+;;;   <http://mumble.net/~campbell/emacs/paredit.el>.
+;;;
+;;; The latest beta version of paredit is available at
+;;;   <http://mumble.net/~campbell/emacs/paredit-beta.el>.
+;;;
+;;; Release notes are available at
+;;;   <http://mumble.net/~campbell/emacs/paredit.release>.
+\f
+;;; Install paredit by placing `paredit.el' in `/path/to/elisp', a
+;;; directory of your choice, and adding to your .emacs file:
+;;;
+;;;   (add-to-list 'load-path "/path/to/elisp")
+;;;   (autoload 'enable-paredit-mode "paredit"
+;;;     "Turn on pseudo-structural editing of Lisp code."
+;;;     t)
+;;;
+;;; Start Paredit Mode on the fly with `M-x paredit-mode RET', or
+;;; always enable it in a major mode `M' (e.g., `lisp') with:
+;;;
+;;;   (add-hook M-mode-hook 'enable-paredit-mode)
+;;;
+;;; Customize paredit using `eval-after-load':
+;;;
+;;;   (eval-after-load 'paredit
+;;;     '(progn
+;;;        (define-key paredit-mode-map (kbd "ESC M-A-C-s-)")
+;;;          'paredit-dwim)))
+;;;
+;;; Send questions, bug reports, comments, feature suggestions, &c.,
+;;; via email to the author's surname at mumble.net.
+;;;
+;;; Paredit should run in GNU Emacs 21 or later and XEmacs 21.5.28 or
+;;; later.
+;;;
+;;; *** WARNING *** IMPORTANT *** DO NOT SUBMIT BUGS BEFORE READING ***
+;;;
+;;; If you plan to submit a bug report, where some sequence of keys in
+;;; Paredit Mode, or some sequence of paredit commands, doesn't do what
+;;; you wanted, then it is helpful to isolate an example in a very
+;;; small buffer, and it is **ABSOLUTELY**ESSENTIAL** that you supply,
+;;; along with the sequence of keys or commands,
+;;;
+;;;   (1) the version of Emacs,
+;;;   (2) the version of paredit.el[*], and
+;;;   (3) the **COMPLETE** state of the buffer used to reproduce the
+;;;       problem, including major mode, minor modes, local key
+;;;       bindings, entire contents of the buffer, leading line breaks
+;;;       or spaces, &c.
+;;;
+;;; It is often extremely difficult to reproduce problems, especially
+;;; with commands such as `paredit-kill'.  If you do not supply **ALL**
+;;; of this information, then it is highly probable that I cannot
+;;; reproduce your problem no matter how hard I try.  So, please,
+;;; include all of the above information.
+;;;
+;;; [*] If you are using a beta version of paredit, be sure that you
+;;;     are using the *latest* edition of the beta version, available
+;;;     at <http://mumble.net/~campbell/emacs/paredit-beta.el>.  If you
+;;;     are not using a beta version, then upgrade either to that or to
+;;;     the latest release version; I cannot support older versions,
+;;;     and I can't fathom any reason why you might be using them.  So
+;;;     the answer to item (2) should be either `release' or `beta'.
+\f
+;;; The paredit minor mode, Paredit Mode, binds common character keys,
+;;; such as `(', `)', `"', and `\', to commands that carefully insert
+;;; S-expression structures in the buffer:
+;;;
+;;;   ( inserts `()', leaving the point in the middle;
+;;;   ) moves the point over the next closing delimiter;
+;;;   " inserts `""' if outside a string, or inserts an escaped
+;;;      double-quote if in the middle of a string, or moves over the
+;;;      closing double-quote if at the end of a string; and
+;;;   \ prompts for the character to escape, to avoid inserting lone
+;;;      backslashes that may break structure.
+;;;
+;;; In comments, these keys insert themselves.  If necessary, you can
+;;; insert these characters literally outside comments by pressing
+;;; `C-q' before these keys, in case a mistake has broken the
+;;; structure.
+;;;
+;;; These key bindings are designed so that when typing new code in
+;;; Paredit Mode, you can generally type exactly the same sequence of
+;;; keys you would have typed without Paredit Mode.
+;;;
+;;; Paredit Mode also binds common editing keys, such as `DEL', `C-d',
+;;; and `C-k', to commands that respect S-expression structures in the
+;;; buffer:
+;;;
+;;;   DEL deletes the previous character, unless it is a delimiter: DEL
+;;;        will move the point backward over a closing delimiter, and
+;;;        will delete a delimiter pair together if between an open and
+;;;        closing delimiter;
+;;;
+;;;   C-d deletes the next character in much the same manner; and
+;;;
+;;;   C-k kills all S-expressions that begin anywhere between the point
+;;;        and the end of the line or the closing delimiter of the
+;;;        enclosing list, whichever is first.
+;;;
+;;; If necessary, you can delete a character, kill a line, &c.,
+;;; irrespective of S-expression structure, by pressing `C-u' before
+;;; these keys, in case a mistake has broken the structure.
+;;;
+;;; Finally, Paredit Mode binds some keys to complex S-expression
+;;; editing operations.  For example, `C-<right>' makes the enclosing
+;;; list slurp up an S-expression to its right (here `|' denotes the
+;;; point):
+;;;
+;;;   (foo (bar | baz) quux)  C-<right>  (foo (bar | baz quux))
+;;;
+;;; Some paredit commands automatically reindent code.  When they do,
+;;; they try to indent as locally as possible, to avoid interfering
+;;; with any indentation you might have manually written.  Only the
+;;; advanced S-expression manipulation commands automatically reindent,
+;;; and only the forms that they immediately operated upon (and their
+;;; subforms).
+;;;
+;;; This code is written for clarity, not efficiency.  It frequently
+;;; walks over S-expressions redundantly.  If you have problems with
+;;; the time it takes to execute some of the commands, let me know.
+
+;;; This assumes Unix-style LF line endings.
+
+(defconst paredit-version 23)
+(defconst paredit-beta-p nil)
+\f
+(eval-and-compile
+
+  (defun paredit-xemacs-p ()
+    ;; No idea where I got this definition from.  Edward O'Connor
+    ;; (hober in #emacs) suggested the current definition.
+    ;;   (and (boundp 'running-xemacs)
+    ;;        running-xemacs)
+    (featurep 'xemacs))
+
+  (defun paredit-gnu-emacs-p ()
+    ;++ This could probably be improved.
+    (not (paredit-xemacs-p)))
+
+  (defmacro xcond (&rest clauses)
+    "Exhaustive COND.
+Signal an error if no clause matches."
+    `(cond ,@clauses
+           (t (error "XCOND lost."))))
+
+  (defalias 'paredit-warn (if (fboundp 'warn) 'warn 'message))
+
+  (defvar paredit-sexp-error-type
+    (with-temp-buffer
+      (insert "(")
+      (condition-case condition
+          (backward-sexp)
+        (error (if (eq (car condition) 'error)
+                   (paredit-warn "%s%s%s%s%s"
+                                 "Paredit is unable to discriminate"
+                                 " S-expression parse errors from"
+                                 " other errors. "
+                                 " This may cause obscure problems. "
+                                 " Please upgrade Emacs."))
+               (car condition)))))
+
+  (defmacro paredit-handle-sexp-errors (body &rest handler)
+    `(condition-case ()
+         ,body
+       (,paredit-sexp-error-type ,@handler)))
+
+  (put 'paredit-handle-sexp-errors 'lisp-indent-function 1)
+
+  (defmacro paredit-ignore-sexp-errors (&rest body)
+    `(paredit-handle-sexp-errors (progn ,@body)
+       nil))
+
+  (put 'paredit-ignore-sexp-errors 'lisp-indent-function 0)
+
+  nil)
+\f
+;;;; Minor Mode Definition
+
+(defvar paredit-mode-map (make-sparse-keymap)
+  "Keymap for the paredit minor mode.")
+
+(defvar paredit-override-check-parens-function
+  (lambda (condition) condition nil)
+  "Function to tell whether unbalanced text should inhibit Paredit Mode.")
+
+;;;###autoload
+(define-minor-mode paredit-mode
+  "Minor mode for pseudo-structurally editing Lisp code.
+With a prefix argument, enable Paredit Mode even if there are
+  unbalanced parentheses in the buffer.
+Paredit behaves badly if parentheses are unbalanced, so exercise
+  caution when forcing Paredit Mode to be enabled, and consider
+  fixing unbalanced parentheses instead.
+\\<paredit-mode-map>"
+  :lighter " Paredit"
+  ;; Setting `paredit-mode' to false here aborts enabling Paredit Mode.
+  (if (and paredit-mode
+           (not current-prefix-arg))
+      (condition-case condition
+          (check-parens)
+        (error
+         (if (not (funcall paredit-override-check-parens-function condition))
+             (progn (setq paredit-mode nil)
+                    (signal (car condition) (cdr condition))))))))
+
+(defun paredit-override-check-parens-interactively (condition)
+  (y-or-n-p (format "Enable Paredit Mode despite condition %S? " condition)))
+
+(defun enable-paredit-mode ()
+  "Turn on pseudo-structural editing of Lisp code."
+  (interactive)
+  (paredit-mode +1))
+
+(defun disable-paredit-mode ()
+  "Turn off pseudo-structural editing of Lisp code."
+  (interactive)
+  (paredit-mode -1))
+
+(defvar paredit-backward-delete-key
+  (xcond ((paredit-xemacs-p)    "BS")
+         ((paredit-gnu-emacs-p) "DEL")))
+
+(defvar paredit-forward-delete-keys
+  (xcond ((paredit-xemacs-p)    '("DEL"))
+         ((paredit-gnu-emacs-p) '("<delete>" "<deletechar>"))))
+\f
+;;;; Paredit Keys
+
+;;; Separating the definition and initialization of this variable
+;;; simplifies the development of paredit, since re-evaluating DEFVAR
+;;; forms doesn't actually do anything.
+
+(defvar paredit-commands nil
+  "List of paredit commands with their keys and examples.")
+
+;;; Each specifier is of the form:
+;;;   (key[s] function (example-input example-output) ...)
+;;; where key[s] is either a single string suitable for passing to KBD
+;;; or a list of such strings.  Entries in this list may also just be
+;;; strings, in which case they are headings for the next entries.
+
+(progn (setq paredit-commands
+ `(
+   "Basic Insertion Commands"
+   ("("         paredit-open-round
+                ("(a b |c d)"
+                 "(a b (|) c d)")
+                ("(foo \"bar |baz\" quux)"
+                 "(foo \"bar (|baz\" quux)"))
+   (")"         paredit-close-round
+                ("(a b |c   )" "(a b c)|")
+                ("; Hello,| world!"
+                 "; Hello,)| world!"))
+   ("M-)"       paredit-close-round-and-newline
+                ("(defun f (x|  ))"
+                 "(defun f (x)\n  |)")
+                ("; (Foo.|"
+                 "; (Foo.)|"))
+   ("["         paredit-open-square
+                ("(a b |c d)"
+                 "(a b [|] c d)")
+                ("(foo \"bar |baz\" quux)"
+                 "(foo \"bar [|baz\" quux)"))
+   ("]"         paredit-close-square
+                ("(define-key keymap [frob|  ] 'frobnicate)"
+                 "(define-key keymap [frob]| 'frobnicate)")
+                ("; [Bar.|"
+                 "; [Bar.]|"))
+\f
+   ("\""        paredit-doublequote
+                ("(frob grovel |full lexical)"
+                 "(frob grovel \"|\" full lexical)"
+                 "(frob grovel \"\"| full lexical)")
+                ("(foo \"bar |baz\" quux)"
+                 "(foo \"bar \\\"|baz\" quux)")
+                ("(frob grovel)   ; full |lexical"
+                 "(frob grovel)   ; full \"|lexical"))
+   ("M-\""      paredit-meta-doublequote
+                ("(foo \"bar |baz\" quux)"
+                 "(foo \"bar baz\"\n     |quux)")
+                ("(foo |(bar #\\x \"baz \\\\ quux\") zot)"
+                 ,(concat "(foo \"|(bar #\\\\x \\\"baz \\\\"
+                          "\\\\ quux\\\")\" zot)")))
+   ("\\"        paredit-backslash
+                ("(string #|)\n  ; Character to escape: x"
+                 "(string #\\x|)")
+                ("\"foo|bar\"\n  ; Character to escape: \""
+                 "\"foo\\\"|bar\""))
+   (";"         paredit-semicolon
+                ("|(frob grovel)"
+                 ";|(frob grovel)")
+                ("(frob |grovel)"
+                 "(frob ;|grovel\n )")
+                ("(frob |grovel (bloit\n               zargh))"
+                 "(frob ;|grovel\n (bloit\n  zargh))")
+                ("(frob grovel)          |"
+                 "(frob grovel)          ;|"))
+   ("M-;"       paredit-comment-dwim
+                ("(foo |bar)   ; baz"
+                 "(foo bar)                               ; |baz")
+                ("(frob grovel)|"
+                 "(frob grovel)                           ;|")
+                ("(zot (foo bar)\n|\n     (baz quux))"
+                 "(zot (foo bar)\n     ;; |\n     (baz quux))")
+                ("(zot (foo bar) |(baz quux))"
+                 "(zot (foo bar)\n     ;; |\n     (baz quux))")
+                ("|(defun hello-world ...)"
+                 ";;; |\n(defun hello-world ...)"))
+\f
+   ("C-j"       paredit-newline
+                ("(let ((n (frobbotz))) |(display (+ n 1)\nport))"
+                 ,(concat "(let ((n (frobbotz)))"
+                          "\n  |(display (+ n 1)"
+                          "\n           port))")))
+
+   "Deleting & Killing"
+   (("C-d" ,@paredit-forward-delete-keys)
+                paredit-forward-delete
+                ("(quu|x \"zot\")" "(quu| \"zot\")")
+                ("(quux |\"zot\")"
+                 "(quux \"|zot\")"
+                 "(quux \"|ot\")")
+                ("(foo (|) bar)" "(foo | bar)")
+                ("|(foo bar)" "(|foo bar)"))
+   (,paredit-backward-delete-key
+                paredit-backward-delete
+                ("(\"zot\" q|uux)" "(\"zot\" |uux)")
+                ("(\"zot\"| quux)"
+                 "(\"zot|\" quux)"
+                 "(\"zo|\" quux)")
+                ("(foo (|) bar)" "(foo | bar)")
+                ("(foo bar)|" "(foo bar|)"))
+   ("C-k"       paredit-kill
+                ("(foo bar)|     ; Useless comment!"
+                 "(foo bar)|")
+                ("(|foo bar)     ; Useful comment!"
+                 "(|)     ; Useful comment!")
+                ("|(foo bar)     ; Useless line!"
+                 "|")
+                ("(foo \"|bar baz\"\n     quux)"
+                 "(foo \"|\"\n     quux)"))
+   ("M-d"       paredit-forward-kill-word
+                ("|(foo bar)    ; baz"
+                 "(| bar)    ; baz"
+                 "(|)    ; baz"
+                 "()    ;|")
+                (";;;| Frobnicate\n(defun frobnicate ...)"
+                 ";;;|\n(defun frobnicate ...)"
+                 ";;;\n(| frobnicate ...)"))
+   (,(concat "M-" paredit-backward-delete-key)
+                paredit-backward-kill-word
+                ("(foo bar)    ; baz\n(quux)|"
+                 "(foo bar)    ; baz\n(|)"
+                 "(foo bar)    ; |\n()"
+                 "(foo |)    ; \n()"
+                 "(|)    ; \n()"))
+
+   "Movement & Navigation"
+   ("C-M-f"     paredit-forward
+                ("(foo |(bar baz) quux)"
+                 "(foo (bar baz)| quux)")
+                ("(foo (bar)|)"
+                 "(foo (bar))|"))
+   ("C-M-b"     paredit-backward
+                ("(foo (bar baz)| quux)"
+                 "(foo |(bar baz) quux)")
+                ("(|(foo) bar)"
+                 "|((foo) bar)"))
+   ("C-M-u"     paredit-backward-up)
+   ("C-M-d"     paredit-forward-down)
+   ("C-M-p"     paredit-backward-down)  ; Built-in, these are FORWARD-
+   ("C-M-n"     paredit-forward-up)     ; & BACKWARD-LIST, which have
+                                        ; no need given C-M-f & C-M-b.
+\f
+   "Depth-Changing Commands"
+   ("M-("       paredit-wrap-round
+                ("(foo |bar baz)"
+                 "(foo (|bar) baz)"))
+   ("M-s"       paredit-splice-sexp
+                ("(foo (bar| baz) quux)"
+                 "(foo bar| baz quux)"))
+   (("M-<up>" "ESC <up>")
+                paredit-splice-sexp-killing-backward
+                ("(foo (let ((x 5)) |(sqrt n)) bar)"
+                 "(foo |(sqrt n) bar)"))
+   (("M-<down>" "ESC <down>")
+                paredit-splice-sexp-killing-forward
+                ("(a (b c| d e) f)"
+                 "(a b c| f)"))
+   ("M-r"       paredit-raise-sexp
+                ("(dynamic-wind in (lambda () |body) out)"
+                 "(dynamic-wind in |body out)"
+                 "|body"))
+   ("M-?"       paredit-convolute-sexp
+                ("(let ((x 5) (y 3)) (frob |(zwonk)) (wibblethwop))"
+                 "(frob |(let ((x 5) (y 3)) (zwonk) (wibblethwop)))"))
+
+   "Barfage & Slurpage"
+   (("C-)" "C-<right>")
+                paredit-forward-slurp-sexp
+                ("(foo (bar |baz) quux zot)"
+                 "(foo (bar |baz quux) zot)")
+                ("(a b ((c| d)) e f)"
+                 "(a b ((c| d) e) f)"))
+   (("C-}" "C-<left>")
+                paredit-forward-barf-sexp
+                ("(foo (bar |baz quux) zot)"
+                 "(foo (bar |baz) quux zot)"))
+   (("C-(" "C-M-<left>" "ESC C-<left>")
+                paredit-backward-slurp-sexp
+                ("(foo bar (baz| quux) zot)"
+                 "(foo (bar baz| quux) zot)")
+                ("(a b ((c| d)) e f)"
+                 "(a (b (c| d)) e f)"))
+   (("C-{" "C-M-<right>" "ESC C-<right>")
+                paredit-backward-barf-sexp
+                ("(foo (bar baz |quux) zot)"
+                 "(foo bar (baz |quux) zot)"))
+
+   "Miscellaneous Commands"
+   ("M-S"       paredit-split-sexp
+                ("(hello| world)"
+                 "(hello)| (world)")
+                ("\"Hello, |world!\""
+                 "\"Hello, \"| \"world!\""))
+   ("M-J"       paredit-join-sexps
+                ("(hello)| (world)"
+                 "(hello| world)")
+                ("\"Hello, \"| \"world!\""
+                 "\"Hello, |world!\"")
+                ("hello-\n|  world"
+                 "hello-|world"))
+   ("C-c C-M-l" paredit-recenter-on-sexp)
+   ("M-q"       paredit-reindent-defun)
+   ))
+       nil)                             ; end of PROGN
+\f
+;;;;; Command Examples
+
+(eval-and-compile
+  (defmacro paredit-do-commands (vars string-case &rest body)
+    (let ((spec     (nth 0 vars))
+          (keys     (nth 1 vars))
+          (fn       (nth 2 vars))
+          (examples (nth 3 vars)))
+      `(dolist (,spec paredit-commands)
+         (if (stringp ,spec)
+             ,string-case
+           (let ((,keys (let ((k (car ,spec)))
+                          (cond ((stringp k) (list k))
+                                ((listp k) k)
+                                (t (error "Invalid paredit command %s."
+                                          ,spec)))))
+                 (,fn (cadr ,spec))
+                 (,examples (cddr ,spec)))
+             ,@body)))))
+
+  (put 'paredit-do-commands 'lisp-indent-function 2))
+
+(defun paredit-define-keys ()
+  (paredit-do-commands (spec keys fn examples)
+      nil       ; string case
+    (dolist (key keys)
+      (define-key paredit-mode-map (read-kbd-macro key) fn))))
+
+(defun paredit-function-documentation (fn)
+  (let ((original-doc (get fn 'paredit-original-documentation))
+        (doc (documentation fn 'function-documentation)))
+    (or original-doc
+        (progn (put fn 'paredit-original-documentation doc)
+               doc))))
+
+(defun paredit-annotate-mode-with-examples ()
+  (let ((contents
+         (list (paredit-function-documentation 'paredit-mode))))
+    (paredit-do-commands (spec keys fn examples)
+        (push (concat "\n\f\n" spec "\n")
+              contents)
+      (let ((name (symbol-name fn)))
+        (if (string-match (symbol-name 'paredit-) name)
+            (push (concat "\n\n\\[" name "]\t" name
+                          (if examples
+                              (mapconcat (lambda (example)
+                                           (concat
+                                            "\n"
+                                            (mapconcat 'identity
+                                                       example
+                                                       "\n  --->\n")
+                                            "\n"))
+                                         examples
+                                         "")
+                              "\n  (no examples)\n"))
+                  contents))))
+    (put 'paredit-mode 'function-documentation
+         (apply 'concat (reverse contents))))
+  ;; PUT returns the huge string we just constructed, which we don't
+  ;; want it to return.
+  nil)
+
+(defun paredit-annotate-functions-with-examples ()
+  (paredit-do-commands (spec keys fn examples)
+      nil       ; string case
+    (put fn 'function-documentation
+         (concat (paredit-function-documentation fn)
+                 "\n\n\\<paredit-mode-map>\\[" (symbol-name fn) "]\n"
+                 (mapconcat (lambda (example)
+                              (concat "\n"
+                                      (mapconcat 'identity
+                                                 example
+                                                 "\n  ->\n")
+                                      "\n"))
+                            examples
+                            "")))))
+\f
+;;;;; HTML Examples
+
+(defun paredit-insert-html-examples ()
+  "Insert HTML for a paredit quick reference table."
+  (interactive)
+  (let ((insert-lines
+         (lambda (&rest lines)
+           (mapc (lambda (line) (insert line) (newline))
+                 lines)))
+        (html-keys
+         (lambda (keys)
+           (mapconcat 'paredit-html-quote keys ", ")))
+        (html-example
+         (lambda (example)
+           (concat "<table><tr><td><pre>"
+                   (mapconcat 'paredit-html-quote
+                              example
+                              (concat "</pre></td></tr><tr><td>"
+                                      "&nbsp;&nbsp;&nbsp;&nbsp;---&gt;"
+                                      "</td></tr><tr><td><pre>"))
+                   "</pre></td></tr></table>")))
+        (firstp t))
+    (paredit-do-commands (spec keys fn examples)
+        (progn (if (not firstp)
+                   (insert "</table>\n")
+                   (setq firstp nil))
+               (funcall insert-lines
+                        (concat "<h3>" spec "</h3>")
+                        "<table border=\"1\" cellpadding=\"1\">"
+                        "  <tr>"
+                        "    <th>Command</th>"
+                        "    <th>Keys</th>"
+                        "    <th>Examples</th>"
+                        "  </tr>"))
+      (let ((name (symbol-name fn)))
+        (if (string-match (symbol-name 'paredit-) name)
+            (funcall insert-lines
+                     "  <tr>"
+                     (concat "    <td><tt>" name "</tt></td>")
+                     (concat "    <td align=\"center\">"
+                             (funcall html-keys keys)
+                             "</td>")
+                     (concat "    <td>"
+                             (if examples
+                                 (mapconcat html-example examples
+                                            "<hr>")
+                                 "(no examples)")
+                             "</td>")
+                     "  </tr>")))))
+  (insert "</table>\n"))
+
+(defun paredit-html-quote (string)
+  (with-temp-buffer
+    (dotimes (i (length string))
+      (insert (let ((c (elt string i)))
+                (cond ((eq c ?\<) "&lt;")
+                      ((eq c ?\>) "&gt;")
+                      ((eq c ?\&) "&amp;")
+                      ((eq c ?\') "&apos;")
+                      ((eq c ?\") "&quot;")
+                      (t c)))))
+    (buffer-string)))
+\f
+;;;; Delimiter Insertion
+
+(eval-and-compile
+  (defun paredit-conc-name (&rest strings)
+    (intern (apply 'concat strings)))
+
+  (defmacro define-paredit-pair (open close name)
+    `(progn
+       (defun ,(paredit-conc-name "paredit-open-" name) (&optional n)
+         ,(concat "Insert a balanced " name " pair.
+With a prefix argument N, put the closing " name " after N
+  S-expressions forward.
+If the region is active, `transient-mark-mode' is enabled, and the
+  region's start and end fall in the same parenthesis depth, insert a
+  " name " pair around the region.
+If in a string or a comment, insert a single " name ".
+If in a character literal, do nothing.  This prevents changing what was
+  in the character literal to a meaningful delimiter unintentionally.")
+         (interactive "P")
+         (cond ((or (paredit-in-string-p)
+                    (paredit-in-comment-p))
+                (insert ,open))
+               ((not (paredit-in-char-p))
+                (paredit-insert-pair n ,open ,close 'goto-char)
+                (save-excursion (backward-up-list) (indent-sexp)))))
+       (defun ,(paredit-conc-name "paredit-close-" name) ()
+         ,(concat "Move past one closing delimiter and reindent.
+\(Agnostic to the specific closing delimiter.)
+If in a string or comment, insert a single closing " name ".
+If in a character literal, do nothing.  This prevents changing what was
+  in the character literal to a meaningful delimiter unintentionally.")
+         (interactive)
+         (paredit-move-past-close ,close))
+       (defun ,(paredit-conc-name "paredit-close-" name "-and-newline") ()
+         ,(concat "Move past one closing delimiter, add a newline,"
+                  " and reindent.
+If there was a margin comment after the closing delimiter, preserve it
+  on the same line.")
+         (interactive)
+         (paredit-move-past-close-and-newline ,close))
+       (defun ,(paredit-conc-name "paredit-wrap-" name)
+           (&optional argument)
+         ,(concat "Wrap the following S-expression.
+See `paredit-wrap-sexp' for more details.")
+         (interactive "P")
+         (paredit-wrap-sexp argument ,open ,close))
+       (add-to-list 'paredit-wrap-commands
+                    ',(paredit-conc-name "paredit-wrap-" name)))))
+
+(defvar paredit-wrap-commands '(paredit-wrap-sexp)
+  "List of paredit commands that wrap S-expressions.
+Used by `paredit-yank-pop'; for internal paredit use only.")
+
+(define-paredit-pair ?\( ?\) "round")
+(define-paredit-pair ?\[ ?\] "square")
+(define-paredit-pair ?\{ ?\} "curly")
+(define-paredit-pair ?\< ?\> "angled")
+
+;;; Aliases for the old names.
+
+(defalias 'paredit-open-parenthesis 'paredit-open-round)
+(defalias 'paredit-close-parenthesis 'paredit-close-round)
+(defalias 'paredit-close-parenthesis-and-newline
+  'paredit-close-round-and-newline)
+
+(defalias 'paredit-open-bracket 'paredit-open-square)
+(defalias 'paredit-close-bracket 'paredit-close-square)
+(defalias 'paredit-close-bracket-and-newline
+  'paredit-close-square-and-newline)
+\f
+(defun paredit-move-past-close (close)
+  (paredit-move-past-close-and close
+    (lambda ()
+      (paredit-blink-paren-match nil))))
+
+(defun paredit-move-past-close-and-newline (close)
+  (paredit-move-past-close-and close
+    (lambda ()
+      (let ((comment.point (paredit-find-comment-on-line)))
+        (newline)
+        (if comment.point
+            (save-excursion
+              (forward-line -1)
+              (end-of-line)
+              (indent-to (cdr comment.point))
+              (insert (car comment.point)))))
+      (lisp-indent-line)
+      (paredit-ignore-sexp-errors (indent-sexp))
+      (paredit-blink-paren-match t))))
+
+(defun paredit-move-past-close-and (close if-moved)
+  (if (or (paredit-in-string-p)
+          (paredit-in-comment-p))
+      (insert close)
+    (if (paredit-in-char-p) (forward-char))
+    (paredit-move-past-close-and-reindent close)
+    (funcall if-moved)))
+
+(defun paredit-find-comment-on-line ()
+  "Find a margin comment on the current line.
+Return nil if there is no such comment or if there is anything but
+  whitespace until such a comment.
+If such a comment exists, delete the comment (including all leading
+  whitespace) and return a cons whose car is the comment as a string
+  and whose cdr is the point of the comment's initial semicolon,
+  relative to the start of the line."
+  (save-excursion
+    (paredit-skip-whitespace t (point-at-eol))
+    (and (eq ?\; (char-after))
+         (not (eq ?\; (char-after (1+ (point)))))
+         (not (or (paredit-in-string-p)
+                  (paredit-in-char-p)))
+         (let* ((start                  ;Move to before the semicolon.
+                 (progn (backward-char) (point)))
+                (comment
+                 (buffer-substring start (point-at-eol))))
+           (paredit-skip-whitespace nil (point-at-bol))
+           (delete-region (point) (point-at-eol))
+           (cons comment (- start (point-at-bol)))))))
+\f
+(defun paredit-insert-pair (n open close forward)
+  (let* ((regionp
+          (and (paredit-region-active-p)
+               (paredit-region-safe-for-insert-p)))
+         (end
+          (and regionp
+               (not n)
+               (prog1 (region-end) (goto-char (region-beginning))))))
+    (let ((spacep (paredit-space-for-delimiter-p nil open)))
+      (if spacep (insert " "))
+      (insert open)
+      (save-excursion
+        ;; Move past the desired region.
+        (cond (n
+               (funcall forward
+                        (paredit-scan-sexps-hack (point)
+                                                 (prefix-numeric-value n))))
+              (regionp
+               (funcall forward (+ end (if spacep 2 1)))))
+        ;; The string case can happen if we are inserting string
+        ;; delimiters.  The comment case may happen by moving to the
+        ;; end of a buffer that has a comment with no trailing newline.
+        (if (and (not (paredit-in-string-p))
+                 (paredit-in-comment-p))
+            (newline))
+        (insert close)
+        (if (paredit-space-for-delimiter-p t close)
+            (insert " "))))))
+
+;++ This needs a better name...
+
+(defun paredit-scan-sexps-hack (point n)
+  (save-excursion
+    (goto-char point)
+    (let ((direction (if (< 0 n) +1 -1))
+          (magnitude (abs n))
+          (count 0))
+      (catch 'exit
+        (while (< count magnitude)
+          (let ((p
+                 (paredit-handle-sexp-errors (scan-sexps (point) direction)
+                   nil)))
+            (if (not p) (throw 'exit nil))
+            (goto-char p))
+          (setq count (+ count 1)))))
+    (point)))
+\f
+(defun paredit-region-safe-for-insert-p ()
+  (save-excursion
+    (let ((beginning (region-beginning))
+          (end (region-end)))
+      (goto-char beginning)
+      (let* ((beginning-state (paredit-current-parse-state))
+             (end-state
+              (parse-partial-sexp beginning end nil nil beginning-state)))
+        (and (=  (nth 0 beginning-state)   ; 0. depth in parens
+                 (nth 0 end-state))
+             (eq (nth 3 beginning-state)   ; 3. non-nil if inside a
+                 (nth 3 end-state))        ;    string
+             (eq (nth 4 beginning-state)   ; 4. comment status, yada
+                 (nth 4 end-state))
+             (eq (nth 5 beginning-state)   ; 5. t if following char
+                 (nth 5 end-state)))))))   ;    quote
+
+(defvar paredit-space-for-delimiter-predicates nil
+  "List of predicates for whether to put space by delimiter at point.
+Each predicate is a function that is is applied to two arguments, ENDP
+  and DELIMITER, and that returns a boolean saying whether to put a
+  space next to the delimiter -- before the delimiter if ENDP is false,
+  after the delimiter if ENDP is true.
+If any predicate returns false, no space is inserted: every predicate
+  has veto power.
+Each predicate may assume that the point is not at the beginning of the
+  buffer, if ENDP is false, or at the end of the buffer, if ENDP is
+  true; and that the point is not preceded, if ENDP is false, or
+  followed, if ENDP is true, by a word or symbol constituent, a quote,
+  or the delimiter matching DELIMITER.
+Each predicate should examine only text before the point, if ENDP is
+  false, or only text after the point, if ENDP is true.")
+
+(defun paredit-space-for-delimiter-p (endp delimiter)
+  ;; If at the buffer limit, don't insert a space.  If there is a word,
+  ;; symbol, other quote, or non-matching parenthesis delimiter (i.e. a
+  ;; close when want an open the string or an open when we want to
+  ;; close the string), do insert a space.
+  (and (not (if endp (eobp) (bobp)))
+       (memq (char-syntax (if endp (char-after) (char-before)))
+             (list ?w ?_ ?\"
+                   (let ((matching (matching-paren delimiter)))
+                     (and matching (char-syntax matching)))
+                   (and (not endp)
+                        (eq ?\" (char-syntax delimiter))
+                        ?\) )))
+       (catch 'exit
+         (dolist (predicate paredit-space-for-delimiter-predicates)
+           (if (not (funcall predicate endp delimiter))
+               (throw 'exit nil)))
+         t)))
+\f
+(defun paredit-move-past-close-and-reindent (close)
+  (let ((open (paredit-missing-close)))
+    (if open
+        (if (eq close (matching-paren open))
+            (save-excursion
+              (message "Missing closing delimiter: %c" close)
+              (insert close))
+            (error "Mismatched missing closing delimiter: %c ... %c"
+                   open close))))
+  (up-list)
+  (if (catch 'return                    ; This CATCH returns T if it
+        (while t                        ; should delete leading spaces
+          (save-excursion               ; and NIL if not.
+            (let ((before-paren (1- (point))))
+              (back-to-indentation)
+              (cond ((not (eq (point) before-paren))
+                     ;; Can't call PAREDIT-DELETE-LEADING-WHITESPACE
+                     ;; here -- we must return from SAVE-EXCURSION
+                     ;; first.
+                     (throw 'return t))
+                    ((save-excursion (forward-line -1)
+                                     (end-of-line)
+                                     (paredit-in-comment-p))
+                     ;; Moving the closing delimiter any further
+                     ;; would put it into a comment, so we just
+                     ;; indent the closing delimiter where it is and
+                     ;; abort the loop, telling its continuation that
+                     ;; no leading whitespace should be deleted.
+                     (lisp-indent-line)
+                     (throw 'return nil))
+                    (t (delete-indentation)))))))
+      (paredit-delete-leading-whitespace)))
+
+(defun paredit-missing-close ()
+  (save-excursion
+    (paredit-handle-sexp-errors (backward-up-list)
+      (error "Not inside a list."))
+    (let ((open (char-after)))
+      (paredit-handle-sexp-errors (progn (forward-sexp) nil)
+        open))))
+
+(defun paredit-delete-leading-whitespace ()
+  ;; This assumes that we're on the closing delimiter already.
+  (save-excursion
+    (backward-char)
+    (while (let ((syn (char-syntax (char-before))))
+             (and (or (eq syn ?\ ) (eq syn ?-))     ; whitespace syntax
+                  ;; The above line is a perfect example of why the
+                  ;; following test is necessary.
+                  (not (paredit-in-char-p (1- (point))))))
+      (backward-delete-char 1))))
+
+(defun paredit-blink-paren-match (another-line-p)
+  (if (and blink-matching-paren
+           (or (not show-paren-mode) another-line-p))
+      (paredit-ignore-sexp-errors
+        (save-excursion
+          (backward-sexp)
+          (forward-sexp)
+          ;; SHOW-PAREN-MODE inhibits any blinking, so we disable it
+          ;; locally here.
+          (let ((show-paren-mode nil))
+            (blink-matching-open))))))
+\f
+(defun paredit-doublequote (&optional n)
+  "Insert a pair of double-quotes.
+With a prefix argument N, wrap the following N S-expressions in
+  double-quotes, escaping intermediate characters if necessary.
+If the region is active, `transient-mark-mode' is enabled, and the
+  region's start and end fall in the same parenthesis depth, insert a
+  pair of double-quotes around the region, again escaping intermediate
+  characters if necessary.
+Inside a comment, insert a literal double-quote.
+At the end of a string, move past the closing double-quote.
+In the middle of a string, insert a backslash-escaped double-quote.
+If in a character literal, do nothing.  This prevents accidentally
+  changing a what was in the character literal to become a meaningful
+  delimiter unintentionally."
+  (interactive "P")
+  (cond ((paredit-in-string-p)
+         (if (eq (cdr (paredit-string-start+end-points))
+                 (point))
+             (forward-char)             ; We're on the closing quote.
+             (insert ?\\ ?\" )))
+        ((paredit-in-comment-p)
+         (insert ?\" ))
+        ((not (paredit-in-char-p))
+         (paredit-insert-pair n ?\" ?\" 'paredit-forward-for-quote))))
+
+(defun paredit-meta-doublequote (&optional n)
+  "Move to the end of the string, insert a newline, and indent.
+If not in a string, act as `paredit-doublequote'; if no prefix argument
+  is specified and the region is not active or `transient-mark-mode' is
+  disabled, the default is to wrap one S-expression, however, not
+  zero."
+  (interactive "P")
+  (if (not (paredit-in-string-p))
+      (paredit-doublequote (or n
+                               (and (not (paredit-region-active-p))
+                                    1)))
+    (let ((start+end (paredit-string-start+end-points)))
+      (goto-char (1+ (cdr start+end)))
+      (newline)
+      (lisp-indent-line)
+      (paredit-ignore-sexp-errors (indent-sexp)))))
+
+(defun paredit-forward-for-quote (end)
+  (let ((state (paredit-current-parse-state)))
+    (while (< (point) end)
+      (let ((new-state (parse-partial-sexp (point) (1+ (point))
+                                           nil nil state)))
+        (if (paredit-in-string-p new-state)
+            (if (not (paredit-in-string-escape-p))
+                (setq state new-state)
+              ;; Escape character: turn it into an escaped escape
+              ;; character by appending another backslash.
+              (insert ?\\ )
+              ;; Now the point is after both escapes, and we want to
+              ;; rescan from before the first one to after the second
+              ;; one.
+              (setq state
+                    (parse-partial-sexp (- (point) 2) (point)
+                                        nil nil state))
+              ;; Advance the end point, since we just inserted a new
+              ;; character.
+              (setq end (1+ end)))
+          ;; String: escape by inserting a backslash before the quote.
+          (backward-char)
+          (insert ?\\ )
+          ;; The point is now between the escape and the quote, and we
+          ;; want to rescan from before the escape to after the quote.
+          (setq state
+                (parse-partial-sexp (1- (point)) (1+ (point))
+                                    nil nil state))
+          ;; Advance the end point for the same reason as above.
+          (setq end (1+ end)))))))
+\f
+;;;; Escape Insertion
+
+(defun paredit-backslash ()
+  "Insert a backslash followed by a character to escape."
+  (interactive)
+  (cond ((paredit-in-string-p) (paredit-backslash-interactive))
+        ((paredit-in-comment-p) (insert ?\\))
+        ((paredit-in-char-p) (forward-char) (paredit-backslash-interactive))
+        (t (paredit-backslash-interactive))))
+
+(defun paredit-backslash-interactive ()
+  (insert ?\\ )
+  ;; Read a character to insert after the backslash.  If anything
+  ;; goes wrong -- the user hits delete (entering the rubout
+  ;; `character'), aborts with C-g, or enters non-character input
+  ;; -- then delete the backslash to avoid a dangling escape.
+  (let ((delete-p t))
+    (unwind-protect
+        (let ((char (read-char "Character to escape: ")))
+          (if (not (eq char ?\^?))
+              (progn (message "Character to escape: %c" char)
+                     (insert char)
+                     (setq delete-p nil))))
+      (if delete-p
+          (progn (message "Deleting escape.")
+                 (backward-delete-char 1))))))
+
+(defun paredit-newline ()
+  "Insert a newline and indent it.
+This is like `newline-and-indent', but it not only indents the line
+  that the point is on but also the S-expression following the point,
+  if there is one.
+Move forward one character first if on an escaped character.
+If in a string, just insert a literal newline.
+If in a comment and if followed by invalid structure, call
+  `indent-new-comment-line' to keep the invalid structure in a
+  comment."
+  (interactive)
+  (cond ((paredit-in-string-p)
+         (newline))
+        ((paredit-in-comment-p)
+         (if (paredit-region-ok-p (point) (point-at-eol))
+             (progn (newline-and-indent)
+                    (paredit-ignore-sexp-errors (indent-sexp)))
+             (indent-new-comment-line)))
+        (t
+         (if (paredit-in-char-p)
+             (forward-char))
+         (newline-and-indent)
+         ;; Indent the following S-expression, but don't signal an
+         ;; error if there's only a closing delimiter after the point.
+         (paredit-ignore-sexp-errors (indent-sexp)))))
+
+(defun paredit-reindent-defun (&optional argument)
+  "Reindent the definition that the point is on.
+If the point is in a string or a comment, fill the paragraph instead,
+  and with a prefix argument, justify as well."
+  (interactive "P")
+  (if (or (paredit-in-string-p)
+          (paredit-in-comment-p))
+      (lisp-fill-paragraph argument)
+    (let ((column (current-column))
+          (indentation (paredit-current-indentation)))
+      (save-excursion (end-of-defun) (beginning-of-defun) (indent-sexp))
+      ;; Preserve the point's position either in the indentation or in
+      ;; the code: if on code, move with the code; if in indentation,
+      ;; leave it in the indentation, either where it was (if that's
+      ;; still indentation) or at the end of the indentation (if the
+      ;; code moved far enough left).
+      (let ((indentation* (paredit-current-indentation)))
+        (goto-char
+         (+ (point-at-bol)
+            (cond ((not (< column indentation))
+                   (+ column (- indentation* indentation)))
+                  ((<= indentation* column) indentation*)
+                  (t column))))))))
+\f
+;;;; Comment Insertion
+
+(defun paredit-semicolon (&optional n)
+  "Insert a semicolon.
+With a prefix argument N, insert N semicolons.
+If in a string, do just that and nothing else.
+If in a character literal, move to the beginning of the character
+  literal before inserting the semicolon.
+If the enclosing list ends on the line after the point, break the line
+  after the last S-expression following the point.
+If a list begins on the line after the point but ends on a different
+  line, break the line after the last S-expression following the point
+  before the list."
+  (interactive "p")
+  (if (or (paredit-in-string-p) (paredit-in-comment-p))
+      (insert (make-string (or n 1) ?\; ))
+    (if (paredit-in-char-p)
+        (backward-char 2))
+    (let ((line-break-point (paredit-semicolon-find-line-break-point)))
+      (if line-break-point
+          (paredit-semicolon-with-line-break line-break-point (or n 1))
+          (insert (make-string (or n 1) ?\; ))))))
+
+(defun paredit-semicolon-find-line-break-point ()
+  (let ((line-break-point nil)
+        (eol (point-at-eol)))
+    (and (not (eolp))                   ;Implies (not (eobp)).
+         (save-excursion
+           (paredit-handle-sexp-errors
+               (progn
+                 (while
+                     (progn
+                       (setq line-break-point (point))
+                       (forward-sexp)
+                       (and (eq eol (point-at-eol))
+                            (not (eobp)))))
+                 (backward-sexp)
+                 (and (eq eol (point-at-eol))
+                      ;; Don't break the line if the end of the last
+                      ;; S-expression is at the end of the buffer.
+                      (progn (forward-sexp) (not (eobp)))))
+             ;; If we hit the end of an expression, but the closing
+             ;; delimiter is on another line, don't break the line.
+             (save-excursion
+               (paredit-skip-whitespace t (point-at-eol))
+               (not (or (eolp) (eq (char-after) ?\; ))))))
+         line-break-point)))
+
+(defun paredit-semicolon-with-line-break (line-break-point n)
+  (let ((line-break-marker (make-marker)))
+    (set-marker line-break-marker line-break-point)
+    (set-marker-insertion-type line-break-marker t)
+    (insert (make-string (or n 1) ?\; ))
+    (save-excursion
+      (goto-char line-break-marker)
+      (set-marker line-break-marker nil)
+      (newline)
+      (lisp-indent-line)
+      ;; This step is redundant if we are inside a list, but even if we
+      ;; are at the top level, we want at least to indent whatever we
+      ;; bumped off the line.
+      (paredit-ignore-sexp-errors (indent-sexp))
+      (paredit-indent-sexps))))
+\f
+;;; This is all a horrible, horrible hack, primarily for GNU Emacs 21,
+;;; in which there is no `comment-or-uncomment-region'.
+
+(autoload 'comment-forward "newcomment")
+(autoload 'comment-normalize-vars "newcomment")
+(autoload 'comment-region "newcomment")
+(autoload 'comment-search-forward "newcomment")
+(autoload 'uncomment-region "newcomment")
+
+(defun paredit-initialize-comment-dwim ()
+  (require 'newcomment)
+  (if (not (fboundp 'comment-or-uncomment-region))
+      (defalias 'comment-or-uncomment-region
+        (lambda (beginning end &optional argument)
+          (interactive "*r\nP")
+          (if (save-excursion (goto-char beginning)
+                              (comment-forward (point-max))
+                              (<= end (point)))
+              (uncomment-region beginning end argument)
+              (comment-region beginning end argument)))))
+  (defalias 'paredit-initialize-comment-dwim 'comment-normalize-vars)
+  (comment-normalize-vars))
+
+(defun paredit-comment-dwim (&optional argument)
+  "Call the Lisp comment command you want (Do What I Mean).
+This is like `comment-dwim', but it is specialized for Lisp editing.
+If transient mark mode is enabled and the mark is active, comment or
+  uncomment the selected region, depending on whether it was entirely
+  commented not not already.
+If there is already a comment on the current line, with no prefix
+  argument, indent to that comment; with a prefix argument, kill that
+  comment.
+Otherwise, insert a comment appropriate for the context and ensure that
+  any code following the comment is moved to the next line.
+At the top level, where indentation is calculated to be at column 0,
+  insert a triple-semicolon comment; within code, where the indentation
+  is calculated to be non-zero, and on the line there is either no code
+  at all or code after the point, insert a double-semicolon comment;
+  and if the point is after all code on the line, insert a single-
+  semicolon margin comment at `comment-column'."
+  (interactive "*P")
+  (paredit-initialize-comment-dwim)
+  (cond ((paredit-region-active-p)
+         (comment-or-uncomment-region (region-beginning)
+                                      (region-end)
+                                      argument))
+        ((paredit-comment-on-line-p)
+         (if argument
+             (comment-kill (if (integerp argument) argument nil))
+             (comment-indent)))
+        (t (paredit-insert-comment))))
+\f
+(defun paredit-comment-on-line-p ()
+  "True if there is a comment on the line following point.
+This is expected to be called only in `paredit-comment-dwim'; do not
+  call it elsewhere."
+  (save-excursion
+    (beginning-of-line)
+    (let ((comment-p nil))
+      ;; Search forward for a comment beginning.  If there is one, set
+      ;; COMMENT-P to true; if not, it will be nil.
+      (while (progn
+               (setq comment-p          ;t -> no error
+                     (comment-search-forward (point-at-eol) t))
+               (and comment-p
+                    (or (paredit-in-string-p)
+                        (paredit-in-char-p (1- (point))))))
+        (forward-char))
+      comment-p)))
+
+(defun paredit-insert-comment ()
+  (let ((code-after-p
+         (save-excursion (paredit-skip-whitespace t (point-at-eol))
+                         (not (eolp))))
+        (code-before-p
+         (save-excursion (paredit-skip-whitespace nil (point-at-bol))
+                         (not (bolp)))))
+    (cond ((and (bolp)
+                (let ((indent
+                       (let ((indent (calculate-lisp-indent)))
+                         (if (consp indent) (car indent) indent))))
+                  (and indent (zerop indent))))
+           ;; Top-level comment
+           (if code-after-p (save-excursion (newline)))
+           (insert ";;; "))
+          ((or code-after-p (not code-before-p))
+           ;; Code comment
+           (if code-before-p
+               (newline-and-indent)
+               (lisp-indent-line))
+           (insert ";; ")
+           (if code-after-p
+               (save-excursion
+                 (newline)
+                 (lisp-indent-line)
+                 (paredit-indent-sexps))))
+          (t
+           ;; Margin comment
+           (indent-to comment-column 1) ; 1 -> force one leading space
+           (insert ?\; )))))
+\f
+;;;; Character Deletion
+
+(defun paredit-forward-delete (&optional argument)
+  "Delete a character forward or move forward over a delimiter.
+If on an opening S-expression delimiter, move forward into the
+  S-expression.
+If on a closing S-expression delimiter, refuse to delete unless the
+  S-expression is empty, in which case delete the whole S-expression.
+With a numeric prefix argument N, delete N characters forward.
+With a `C-u' prefix argument, simply delete a character forward,
+  without regard for delimiter balancing."
+  (interactive "P")
+  (cond ((or (consp argument) (eobp))
+         (delete-char 1))
+        ((integerp argument)
+         (if (< argument 0)
+             (paredit-backward-delete argument)
+             (while (> argument 0)
+               (paredit-forward-delete)
+               (setq argument (- argument 1)))))
+        ((paredit-in-string-p)
+         (paredit-forward-delete-in-string))
+        ((paredit-in-comment-p)
+         (paredit-forward-delete-in-comment))
+        ((paredit-in-char-p)            ; Escape -- delete both chars.
+         (backward-delete-char 1)
+         (delete-char 1))
+        ((eq (char-after) ?\\ )         ; ditto
+         (delete-char 2))
+        ((let ((syn (char-syntax (char-after))))
+           (or (eq syn ?\( )
+               (eq syn ?\" )))
+         (if (save-excursion
+               (paredit-handle-sexp-errors (progn (forward-sexp) t)
+                 nil))
+             (forward-char)
+           (message "Deleting spurious opening delimiter.")
+           (delete-char 1)))
+        ((and (not (paredit-in-char-p (1- (point))))
+              (eq (char-syntax (char-after)) ?\) )
+              (eq (char-before) (matching-paren (char-after))))
+         (backward-delete-char 1)       ; Empty list -- delete both
+         (delete-char 1))               ;   delimiters.
+        ((eq ?\; (char-after))
+         (paredit-forward-delete-comment-start))
+        ;; Just delete a single character, if it's not a closing
+        ;; delimiter.  (The character literal case is already handled
+        ;; by now.)
+        ((not (eq (char-syntax (char-after)) ?\) ))
+         (delete-char 1))))
+\f
+(defun paredit-forward-delete-in-string ()
+  (let ((start+end (paredit-string-start+end-points)))
+    (cond ((not (eq (point) (cdr start+end)))
+           ;; If it's not the close-quote, it's safe to delete.  But
+           ;; first handle the case that we're in a string escape.
+           (cond ((paredit-in-string-escape-p)
+                  ;; We're right after the backslash, so backward
+                  ;; delete it before deleting the escaped character.
+                  (backward-delete-char 1))
+                 ((eq (char-after) ?\\ )
+                  ;; If we're not in a string escape, but we are on a
+                  ;; backslash, it must start the escape for the next
+                  ;; character, so delete the backslash before deleting
+                  ;; the next character.
+                  (delete-char 1)))
+           (delete-char 1))
+          ((eq (1- (point)) (car start+end))
+           ;; If it is the close-quote, delete only if we're also right
+           ;; past the open-quote (i.e. it's empty), and then delete
+           ;; both quotes.  Otherwise we refuse to delete it.
+           (backward-delete-char 1)
+           (delete-char 1)))))
+
+(defun paredit-forward-delete-in-comment ()
+  ;; Point is in a comment, possibly at eol.  Refuse to delete a
+  ;; comment end if moving the next line into the comment would break
+  ;; structure.
+  (if (eolp)
+      (let ((next-line-start (point-at-bol 2))
+            (next-line-end (point-at-eol 2)))
+        (paredit-check-region next-line-start next-line-end)))
+  (delete-char 1))
+
+(defun paredit-forward-delete-comment-start ()
+  ;; Point precedes a comment start (not at eol).  Refuse to delete a
+  ;; comment start if the comment contains unbalanced junk.
+  (paredit-check-region (+ (point) 1) (point-at-eol))
+  (delete-char 1))
+\f
+(defun paredit-backward-delete (&optional argument)
+  "Delete a character backward or move backward over a delimiter.
+If on a closing S-expression delimiter, move backward into the
+  S-expression.
+If on an opening S-expression delimiter, refuse to delete unless the
+  S-expression is empty, in which case delete the whole S-expression.
+With a numeric prefix argument N, delete N characters backward.
+With a `C-u' prefix argument, simply delete a character backward,
+  without regard for delimiter balancing."
+  (interactive "P")
+  (cond ((or (consp argument) (bobp))
+         ;++ Should this untabify?
+         (backward-delete-char 1))
+        ((integerp argument)
+         (if (< argument 0)
+             (paredit-forward-delete (- 0 argument))
+             (while (> argument 0)
+               (paredit-backward-delete)
+               (setq argument (- argument 1)))))
+        ((paredit-in-string-p)
+         (paredit-backward-delete-in-string))
+        ((paredit-in-comment-p)
+         (paredit-backward-delete-in-comment))
+        ((paredit-in-char-p)            ; Escape -- delete both chars.
+         (backward-delete-char 1)
+         (delete-char 1))
+        ((paredit-in-char-p (1- (point)))
+         (backward-delete-char 2))      ; ditto
+        ((let ((syn (char-syntax (char-before))))
+           (or (eq syn ?\) )
+               (eq syn ?\" )))
+         (if (save-excursion
+               (paredit-handle-sexp-errors (progn (backward-sexp) t)
+                 nil))
+             (backward-char)
+           (message "Deleting spurious closing delimiter.")
+           (backward-delete-char 1)))
+        ((and (eq (char-syntax (char-before)) ?\( )
+              (eq (char-after) (matching-paren (char-before))))
+         (backward-delete-char 1)       ; Empty list -- delete both
+         (delete-char 1))               ;   delimiters.
+        ((bolp)
+         (paredit-backward-delete-maybe-comment-end))
+        ;; Delete it, unless it's an opening delimiter.  The case of
+        ;; character literals is already handled by now.
+        ((not (eq (char-syntax (char-before)) ?\( ))
+         (backward-delete-char-untabify 1))))
+\f
+(defun paredit-backward-delete-in-string ()
+  (let ((start+end (paredit-string-start+end-points)))
+    (cond ((not (eq (1- (point)) (car start+end)))
+           ;; If it's not the open-quote, it's safe to delete.
+           (if (paredit-in-string-escape-p)
+               ;; If we're on a string escape, since we're about to
+               ;; delete the backslash, we must first delete the
+               ;; escaped char.
+               (delete-char 1))
+           (backward-delete-char 1)
+           (if (paredit-in-string-escape-p)
+               ;; If, after deleting a character, we find ourselves in
+               ;; a string escape, we must have deleted the escaped
+               ;; character, and the backslash is behind the point, so
+               ;; backward delete it.
+               (backward-delete-char 1)))
+          ((eq (point) (cdr start+end))
+           ;; If it is the open-quote, delete only if we're also right
+           ;; past the close-quote (i.e. it's empty), and then delete
+           ;; both quotes.  Otherwise we refuse to delete it.
+           (backward-delete-char 1)
+           (delete-char 1)))))
+
+(defun paredit-backward-delete-in-comment ()
+  ;; Point is in a comment, possibly just after the comment start.
+  ;; Refuse to delete a comment start if the comment contains
+  ;; unbalanced junk.
+  (if (save-excursion
+        (backward-char)
+        ;; Must call `paredit-in-string-p' before
+        ;; `paredit-in-comment-p'.
+        (not (or (paredit-in-string-p) (paredit-in-comment-p))))
+      (paredit-check-region (point) (point-at-eol)))
+  (backward-delete-char-untabify +1))
+
+(defun paredit-backward-delete-maybe-comment-end ()
+  ;; Point is at bol, possibly just after a comment end (i.e., the
+  ;; previous line may have had a line comment).  Refuse to delete a
+  ;; comment end if moving the current line into the previous line's
+  ;; comment would break structure.
+  (if (save-excursion
+        (backward-char)
+        (and (not (paredit-in-string-p)) (paredit-in-comment-p)))
+      (paredit-check-region (point-at-eol) (point-at-bol)))
+  (backward-delete-char 1))
+\f
+;;;; Killing
+
+(defun paredit-kill (&optional argument)
+  "Kill a line as if with `kill-line', but respecting delimiters.
+In a string, act exactly as `kill-line' but do not kill past the
+  closing string delimiter.
+On a line with no S-expressions on it starting after the point or
+  within a comment, act exactly as `kill-line'.
+Otherwise, kill all S-expressions that start after the point.
+With a `C-u' prefix argument, just do the standard `kill-line'.
+With a numeric prefix argument N, do `kill-line' that many times."
+  (interactive "P")
+  (cond (argument
+         (kill-line (if (integerp argument) argument 1)))
+        ((paredit-in-string-p)
+         (paredit-kill-line-in-string))
+        ((paredit-in-comment-p)
+         (paredit-kill-line-in-comment))
+        ((save-excursion (paredit-skip-whitespace t (point-at-eol))
+                         (or (eolp) (eq (char-after) ?\; )))
+         ;** Be careful about trailing backslashes.
+         (if (paredit-in-char-p)
+             (backward-char))
+         (kill-line))
+        (t (paredit-kill-sexps-on-line))))
+
+(defun paredit-kill-line-in-string ()
+  (if (save-excursion (paredit-skip-whitespace t (point-at-eol))
+                      (eolp))
+      (kill-line)
+    (save-excursion
+      ;; Be careful not to split an escape sequence.
+      (if (paredit-in-string-escape-p)
+          (backward-char))
+      (kill-region (point)
+                   (min (point-at-eol)
+                        (cdr (paredit-string-start+end-points)))))))
+
+(defun paredit-kill-line-in-comment ()
+  ;; If we're at the end of line, this is the same as deleting the line
+  ;; end, which `paredit-forward-delete-in-comment' handles carefully.
+  ;; The variable `kill-whole-line' is not relevant: the point is in a
+  ;; comment, and hence not at the beginning of the line.
+  (if (eolp)
+      (paredit-forward-delete-in-comment)
+      (kill-line)))
+
+(defun paredit-kill-sexps-on-line ()
+  (if (paredit-in-char-p)               ; Move past the \ and prefix.
+      (backward-char 2))                ; (# in Scheme/CL, ? in elisp)
+  (let ((beginning (point))
+        (eol (point-at-eol)))
+    (let ((end-of-list-p (paredit-forward-sexps-to-kill beginning eol)))
+      ;; If we got to the end of the list and it's on the same line,
+      ;; move backward past the closing delimiter before killing.  (This
+      ;; allows something like killing the whitespace in (    ).)
+      (if end-of-list-p (progn (up-list) (backward-char)))
+      (if kill-whole-line
+          (paredit-kill-sexps-on-whole-line beginning)
+        (kill-region beginning
+                     ;; If all of the S-expressions were on one line,
+                     ;; i.e. we're still on that line after moving past
+                     ;; the last one, kill the whole line, including
+                     ;; any comments; otherwise just kill to the end of
+                     ;; the last S-expression we found.  Be sure,
+                     ;; though, not to kill any closing parentheses.
+                     (if (and (not end-of-list-p)
+                              (eq (point-at-eol) eol))
+                         eol
+                         (point)))))))
+\f
+;;; Please do not try to understand this code unless you have a VERY
+;;; good reason to do so.  I gave up trying to figure it out well
+;;; enough to explain it, long ago.
+
+(defun paredit-forward-sexps-to-kill (beginning eol)
+  (let ((end-of-list-p nil)
+        (firstp t))
+    ;; Move to the end of the last S-expression that started on this
+    ;; line, or to the closing delimiter if the last S-expression in
+    ;; this list is on the line.
+    (catch 'return
+      (while t
+        ;; This and the `kill-whole-line' business below fix a bug that
+        ;; inhibited any S-expression at the very end of the buffer
+        ;; (with no trailing newline) from being deleted.  It's a
+        ;; bizarre fix that I ought to document at some point, but I am
+        ;; too busy at the moment to do so.
+        (if (and kill-whole-line (eobp)) (throw 'return nil))
+        (save-excursion
+          (paredit-handle-sexp-errors (forward-sexp)
+            (up-list)
+            (setq end-of-list-p (eq (point-at-eol) eol))
+            (throw 'return nil))
+          (if (or (and (not firstp)
+                       (not kill-whole-line)
+                       (eobp))
+                  (paredit-handle-sexp-errors
+                      (progn (backward-sexp) nil)
+                    t)
+                  (not (eq (point-at-eol) eol)))
+              (throw 'return nil)))
+        (forward-sexp)
+        (if (and firstp
+                 (not kill-whole-line)
+                 (eobp))
+            (throw 'return nil))
+        (setq firstp nil)))
+    end-of-list-p))
+
+(defun paredit-kill-sexps-on-whole-line (beginning)
+  (kill-region beginning
+               (or (save-excursion     ; Delete trailing indentation...
+                     (paredit-skip-whitespace t)
+                     (and (not (eq (char-after) ?\; ))
+                          (point)))
+                   ;; ...or just use the point past the newline, if
+                   ;; we encounter a comment.
+                   (point-at-eol)))
+  (cond ((save-excursion (paredit-skip-whitespace nil (point-at-bol))
+                         (bolp))
+         ;; Nothing but indentation before the point, so indent it.
+         (lisp-indent-line))
+        ((eobp) nil)       ; Protect the CHAR-SYNTAX below against NIL.
+        ;; Insert a space to avoid invalid joining if necessary.
+        ((let ((syn-before (char-syntax (char-before)))
+               (syn-after  (char-syntax (char-after))))
+           (or (and (eq syn-before ?\) )            ; Separate opposing
+                    (eq syn-after  ?\( ))           ;   parentheses,
+               (and (eq syn-before ?\" )            ; string delimiter
+                    (eq syn-after  ?\" ))           ;   pairs,
+               (and (memq syn-before '(?_ ?w))      ; or word or symbol
+                    (memq syn-after  '(?_ ?w)))))   ;   constituents.
+         (insert " "))))
+\f
+;;;;; Killing Words
+
+;;; This is tricky and asymmetrical because backward parsing is
+;;; extraordinarily difficult or impossible, so we have to implement
+;;; killing in both directions by parsing forward.
+
+(defun paredit-forward-kill-word ()
+  "Kill a word forward, skipping over intervening delimiters."
+  (interactive)
+  (let ((beginning (point)))
+    (skip-syntax-forward " -")
+    (let* ((parse-state (paredit-current-parse-state))
+           (state (paredit-kill-word-state parse-state 'char-after)))
+      (while (not (or (eobp)
+                      (eq ?w (char-syntax (char-after)))))
+        (setq parse-state
+              (progn (forward-char 1) (paredit-current-parse-state))
+;;               (parse-partial-sexp (point) (1+ (point))
+;;                                   nil nil parse-state)
+              )
+        (let* ((old-state state)
+               (new-state
+                (paredit-kill-word-state parse-state 'char-after)))
+          (cond ((not (eq old-state new-state))
+                 (setq parse-state
+                       (paredit-kill-word-hack old-state
+                                               new-state
+                                               parse-state))
+                 (setq state
+                       (paredit-kill-word-state parse-state
+                                                'char-after))
+                 (setq beginning (point)))))))
+    (goto-char beginning)
+    (kill-word 1)))
+
+(defun paredit-backward-kill-word ()
+  "Kill a word backward, skipping over any intervening delimiters."
+  (interactive)
+  (if (not (or (bobp)
+               (eq (char-syntax (char-before)) ?w)))
+      (let ((end (point)))
+        (backward-word 1)
+        (forward-word 1)
+        (goto-char (min end (point)))
+        (let* ((parse-state (paredit-current-parse-state))
+               (state
+                (paredit-kill-word-state parse-state 'char-before)))
+          (while (and (< (point) end)
+                      (progn
+                        (setq parse-state
+                              (parse-partial-sexp (point) (1+ (point))
+                                                  nil nil parse-state))
+                        (or (eq state
+                                (paredit-kill-word-state parse-state
+                                                         'char-before))
+                            (progn (backward-char 1) nil)))))
+          (if (and (eq state 'comment)
+                   (eq ?\# (char-after (point)))
+                   (eq ?\| (char-before (point))))
+              (backward-char 1)))))
+  (backward-kill-word 1))
+\f
+;;;;;; Word-Killing Auxiliaries
+
+(defun paredit-kill-word-state (parse-state adjacent-char-fn)
+  (cond ((paredit-in-comment-p parse-state) 'comment)
+        ((paredit-in-string-p  parse-state) 'string)
+        ((memq (char-syntax (funcall adjacent-char-fn))
+               '(?\( ?\) ))
+         'delimiter)
+        (t 'other)))
+
+;;; This optionally advances the point past any comment delimiters that
+;;; should probably not be touched, based on the last state change and
+;;; the characters around the point.  It returns a new parse state,
+;;; starting from the PARSE-STATE parameter.
+
+(defun paredit-kill-word-hack (old-state new-state parse-state)
+  (cond ((and (not (eq old-state 'comment))
+              (not (eq new-state 'comment))
+              (not (paredit-in-string-escape-p))
+              (eq ?\# (char-before))
+              (eq ?\| (char-after)))
+         (forward-char 1)
+         (paredit-current-parse-state)
+;;          (parse-partial-sexp (point) (1+ (point))
+;;                              nil nil parse-state)
+         )
+        ((and (not (eq old-state 'comment))
+              (eq new-state 'comment)
+              (eq ?\; (char-before)))
+         (skip-chars-forward ";")
+         (paredit-current-parse-state)
+;;          (parse-partial-sexp (point) (save-excursion
+;;                                        (skip-chars-forward ";"))
+;;                              nil nil parse-state)
+         )
+        (t parse-state)))
+
+(defun paredit-copy-as-kill ()
+  "Save in the kill ring the region that `paredit-kill' would kill."
+  (interactive)
+  (cond ((paredit-in-string-p)
+         (paredit-copy-as-kill-in-string))
+        ((paredit-in-comment-p)
+         (copy-region-as-kill (point) (point-at-eol)))
+        ((save-excursion (paredit-skip-whitespace t (point-at-eol))
+                         (or (eolp) (eq (char-after) ?\; )))
+         ;** Be careful about trailing backslashes.
+         (save-excursion
+           (if (paredit-in-char-p)
+               (backward-char))
+           (copy-region-as-kill (point) (point-at-eol))))
+        (t (paredit-copy-sexps-as-kill))))
+
+(defun paredit-copy-as-kill-in-string ()
+  (save-excursion
+    (if (paredit-in-string-escape-p)
+        (backward-char))
+    (copy-region-as-kill (point)
+                         (min (point-at-eol)
+                              (cdr (paredit-string-start+end-points))))))
+
+(defun paredit-copy-sexps-as-kill ()
+  (save-excursion
+    (if (paredit-in-char-p)
+        (backward-char 2))
+    (let ((beginning (point))
+          (eol (point-at-eol)))
+      (let ((end-of-list-p (paredit-forward-sexps-to-kill beginning eol)))
+        (if end-of-list-p (progn (up-list) (backward-char)))
+        (copy-region-as-kill beginning
+                             (cond (kill-whole-line
+                                    (or (save-excursion
+                                          (paredit-skip-whitespace t)
+                                          (and (not (eq (char-after) ?\; ))
+                                               (point)))
+                                        (point-at-eol)))
+                                   ((and (not end-of-list-p)
+                                         (eq (point-at-eol) eol))
+                                    eol)
+                                   (t
+                                    (point))))))))
+\f
+;;;; Deleting Regions
+
+(defun paredit-delete-region (start end)
+  "Delete the text between point and mark, like `delete-region'.
+If that text is unbalanced, signal an error instead.
+With a prefix argument, skip the balance check."
+  (interactive "r")
+  (if (and start end (not current-prefix-arg))
+      (paredit-check-region-for-delete start end))
+  (setq this-command 'delete-region)
+  (delete-region start end))
+
+(defun paredit-kill-region (start end)
+  "Kill the text between point and mark, like `kill-region'.
+If that text is unbalanced, signal an error instead.
+With a prefix argument, skip the balance check."
+  (interactive "r")
+  (if (and start end (not current-prefix-arg))
+      (paredit-check-region-for-delete start end))
+  (setq this-command 'kill-region)
+  (kill-region start end))
+
+(defun paredit-check-region-for-delete (start end)
+  "Signal an error deleting text between START and END is unsafe."
+  (save-excursion
+    (goto-char start)
+    (let* ((start-state (paredit-current-parse-state))
+           (end-state (parse-partial-sexp start end nil nil start-state)))
+      (paredit-check-region-for-delete:depth start start-state end end-state)
+      (paredit-check-region-for-delete:string start start-state end end-state)
+      (paredit-check-region-for-delete:comment start start-state end end-state)
+      (paredit-check-region-for-delete:char-quote start start-state
+                                                  end end-state))))
+
+(defun paredit-check-region-for-delete:depth (start start-state end end-state)
+  (let ((start-depth (nth 0 start-state))
+        (end-depth (nth 0 end-state)))
+    (if (not (= start-depth end-depth))
+        (error "Mismatched parenthesis depth: %S at start, %S at end."
+               start-depth
+               end-depth))))
+
+(defun paredit-check-region-for-delete:string (start start-state end end-state)
+  (let ((start-string-p (nth 3 start-state))
+        (end-string-p (nth 3 end-state)))
+    (if (not (eq start-string-p end-string-p))
+        (error "Mismatched string state: start %sin string, end %sin string."
+               (if start-string-p "" "not ")
+               (if end-string-p "" "not ")))))
+\f
+(defun paredit-check-region-for-delete:comment
+    (start start-state end end-state)
+  (let ((start-comment-state (nth 4 start-state))
+        (end-comment-state (nth 4 end-state)))
+    (if (not (or (eq start-comment-state end-comment-state)
+                 ;; If we are moving text into or out of a line
+                 ;; comment, make sure that the text is balanced.  (The
+                 ;; comment state may be a number, not t or nil at all,
+                 ;; for nestable comments, which are not handled by
+                 ;; this heuristic (or any of paredit, really).)
+                 (and (or (and (eq start-comment-state nil)
+                               (eq end-comment-state t))
+                          (and (eq start-comment-state t)
+                               (eq end-comment-state nil)))
+                      (save-excursion
+                        (goto-char end)
+                        (paredit-region-ok-p (point) (point-at-eol))))))
+        (error "Mismatched comment state: %s"
+               (cond ((and (integerp start-comment-state)
+                           (integerp end-comment-state))
+                      (format "depth %S at start, depth %S at end."
+                              start-comment-state
+                              end-comment-state))
+                     ((integerp start-comment-state)
+                      "start in nested comment, end otherwise.")
+                     ((integerp end-comment-state)
+                      "end in nested comment, start otherwise.")
+                     (start-comment-state
+                      "start in comment, end not in comment.")
+                     (end-comment-state
+                      "end in comment, start not in comment.")
+                     (t
+                      (format "start %S, end %S."
+                              start-comment-state
+                              end-comment-state)))))))
+
+(defun paredit-check-region-for-delete:char-quote
+    (start start-state end end-state)
+  (let ((start-char-quote (nth 5 start-state))
+        (end-char-quote (nth 5 end-state)))
+    (if (not (eq start-char-quote end-char-quote))
+        (let ((phrase "character quotation"))
+          (error "Mismatched %s: start %sin %s, end %sin %s."
+                 phrase
+                 (if start-char-quote "" "not ")
+                 phrase
+                 (if end-char-quote "" "not ")
+                 phrase)))))
+\f
+;;;; Point Motion
+
+(eval-and-compile
+  (defmacro defun-saving-mark (name bvl doc &rest body)
+    `(defun ,name ,bvl
+       ,doc
+       ,(xcond ((paredit-xemacs-p)
+                '(interactive "_"))
+               ((paredit-gnu-emacs-p)
+                '(interactive)))
+       ,@body)))
+
+(defun-saving-mark paredit-forward ()
+  "Move forward an S-expression, or up an S-expression forward.
+If there are no more S-expressions in this one before the closing
+  delimiter, move past that closing delimiter; otherwise, move forward
+  past the S-expression following the point."
+  (paredit-handle-sexp-errors
+      (forward-sexp)
+    ;; Use `up-list' if outside a string in case there is whitespace
+    ;; between the point and the end of the list.
+    (if (paredit-in-string-p) (forward-char) (up-list))))
+
+(defun-saving-mark paredit-backward ()
+  "Move backward an S-expression, or up an S-expression backward.
+If there are no more S-expressions in this one before the opening
+  delimiter, move past that opening delimiter backward; otherwise, move
+  move backward past the S-expression preceding the point."
+  (paredit-handle-sexp-errors
+      (backward-sexp)
+    ;; Use `backward-up-list' if outside a string in case there is
+    ;; whitespace between the point and the beginning of the list.
+    (if (paredit-in-string-p) (backward-char) (backward-up-list))))
+
+;;; Why is this not in lisp.el?
+
+(defun backward-down-list (&optional arg)
+  "Move backward and descend into one level of parentheses.
+With ARG, do this that many times.
+A negative argument means move forward but still descend a level."
+  (interactive "p")
+  (down-list (- (or arg 1))))
+\f
+;;;; Window Positioning
+
+(defalias 'paredit-recentre-on-sexp 'paredit-recenter-on-sexp)
+
+(defun paredit-recenter-on-sexp (&optional n)
+  "Recenter the screen on the S-expression following the point.
+With a prefix argument N, encompass all N S-expressions forward."
+  (interactive "P")
+  (let* ((p (point))
+         (end-point (progn (forward-sexp n) (point)))
+         (start-point (progn (goto-char end-point) (backward-sexp n) (point))))
+    ;; Point is at beginning of first S-expression.
+    (let ((p-visible nil) (start-visible nil))
+      (save-excursion
+        (forward-line (/ (count-lines start-point end-point) 2))
+        (recenter)
+        (setq p-visible (pos-visible-in-window-p p))
+        (setq start-visible (pos-visible-in-window-p start-point)))
+      (cond ((not start-visible)
+             ;; Implies (not p-visible).  Put the start at the top of
+             ;; the screen.
+             (recenter 0))
+            (p-visible
+             ;; Go back to p if we can.
+             (goto-char p))))))
+
+(defun paredit-recenter-on-defun ()
+  "Recenter the screen on the definition at point."
+  (interactive)
+  (save-excursion
+    (beginning-of-defun)
+    (paredit-recenter-on-sexp)))
+
+(defun paredit-focus-on-defun ()
+  "Moves display to the top of the definition at point."
+  (interactive)
+  (beginning-of-defun)
+  (recenter 0))
+\f
+;;;; Generalized Upward/Downward Motion
+
+(defun paredit-up/down (n vertical-direction)
+  (let ((horizontal-direction (if (< 0 n) +1 -1)))
+    (while (/= n 0)
+      (goto-char
+       (paredit-next-up/down-point horizontal-direction vertical-direction))
+      (setq n (- n horizontal-direction)))))
+
+(defun paredit-next-up/down-point (horizontal-direction vertical-direction)
+  (let ((state (paredit-current-parse-state))
+        (scan-lists
+         (lambda ()
+           (scan-lists (point) horizontal-direction vertical-direction))))
+    (cond ((paredit-in-string-p state)
+           (let ((start+end (paredit-string-start+end-points state)))
+             (if (< 0 vertical-direction)
+                 (if (< 0 horizontal-direction)
+                     (+ 1 (cdr start+end))
+                     (car start+end))
+                 ;; We could let the user try to descend into lists
+                 ;; within the string, but that would be asymmetric
+                 ;; with the up case, which rises out of the whole
+                 ;; string and not just out of a list within the
+                 ;; string, so this case will just be an error.
+                 (error "Can't descend further into string."))))
+          ((< 0 vertical-direction)
+           ;; When moving up, just try to rise up out of the list.
+           (or (funcall scan-lists)
+               (buffer-end horizontal-direction)))
+          ((< vertical-direction 0)
+           ;; When moving down, look for a string closer than a list,
+           ;; and use that if we find it.
+           (let* ((list-start
+                   (paredit-handle-sexp-errors (funcall scan-lists) nil))
+                  (string-start
+                   (paredit-find-next-string-start horizontal-direction
+                                                   list-start)))
+             (if (and string-start list-start)
+                 (if (< 0 horizontal-direction)
+                     (min string-start list-start)
+                     (max string-start list-start))
+                 (or string-start
+                     ;; Scan again: this is a kludgey way to report the
+                     ;; error if there really was one.
+                     (funcall scan-lists)
+                     (buffer-end horizontal-direction)))))
+          (t
+           (error "Vertical direction must be nonzero in `%s'."
+                  'paredit-up/down)))))
+\f
+(defun paredit-find-next-string-start (horizontal-direction limit)
+  (let ((buffer-limit-p (if (< 0 horizontal-direction) 'eobp 'bobp))
+        (next-char (if (< 0 horizontal-direction) 'char-after 'char-before))
+        (pastp (if (< 0 horizontal-direction) '> '<)))
+    (paredit-handle-sexp-errors
+        (save-excursion
+          (catch 'exit
+            (while t
+              (if (or (funcall buffer-limit-p)
+                      (and limit (funcall pastp (point) limit)))
+                  (throw 'exit nil))
+              (forward-sexp horizontal-direction)
+              (save-excursion
+                (backward-sexp horizontal-direction)
+                (if (eq ?\" (char-syntax (funcall next-char)))
+                    (throw 'exit (+ (point) horizontal-direction)))))))
+      nil)))
+
+(defun paredit-forward-down (&optional argument)
+  "Move forward down into a list.
+With a positive argument, move forward down that many levels.
+With a negative argument, move backward down that many levels."
+  (interactive "p")
+  (paredit-up/down (or argument +1) -1))
+
+(defun paredit-backward-up (&optional argument)
+  "Move backward up out of the enclosing list.
+With a positive argument, move backward up that many levels.
+With a negative argument, move forward up that many levels.
+If in a string initially, that counts as one level."
+  (interactive "p")
+  (paredit-up/down (- 0 (or argument +1)) +1))
+
+(defun paredit-forward-up (&optional argument)
+  "Move forward up out of the enclosing list.
+With a positive argument, move forward up that many levels.
+With a negative argument, move backward up that many levels.
+If in a string initially, that counts as one level."
+  (interactive "p")
+  (paredit-up/down (or argument +1) +1))
+
+(defun paredit-backward-down (&optional argument)
+  "Move backward down into a list.
+With a positive argument, move backward down that many levels.
+With a negative argument, move forward down that many levels."
+  (interactive "p")
+  (paredit-up/down (- 0 (or argument +1)) -1))
+\f
+;;;; Depth-Changing Commands:  Wrapping, Splicing, & Raising
+
+(defun paredit-wrap-sexp (&optional argument open close)
+  "Wrap the following S-expression.
+If a `C-u' prefix argument is given, wrap all S-expressions following
+  the point until the end of the buffer or of the enclosing list.
+If a numeric prefix argument N is given, wrap N S-expressions.
+Automatically indent the newly wrapped S-expression.
+As a special case, if the point is at the end of a list, simply insert
+  a parenthesis pair, rather than inserting a lone opening delimiter
+  and then signalling an error, in the interest of preserving
+  structure.
+By default OPEN and CLOSE are round delimiters."
+  (interactive "P")
+  (paredit-lose-if-not-in-sexp 'paredit-wrap-sexp)
+  (let ((open (or open ?\( ))
+        (close (or close ?\) )))
+    (paredit-handle-sexp-errors
+        ((lambda (n) (paredit-insert-pair n open close 'goto-char))
+         (cond ((integerp argument) argument)
+               ((consp argument) (paredit-count-sexps-forward))
+               ((paredit-region-active-p) nil)
+               (t 1)))
+      (insert close)
+      (backward-char)))
+  (save-excursion (backward-up-list) (indent-sexp)))
+
+(defun paredit-count-sexps-forward ()
+  (save-excursion
+    (let ((n 0) (p nil))                ;hurk
+      (paredit-ignore-sexp-errors
+        (while (setq p (scan-sexps (point) +1))
+          (goto-char p)
+          (setq n (+ n 1))))
+      n)))
+
+(defun paredit-yank-pop (&optional argument)
+  "Replace just-yanked text with the next item in the kill ring.
+If this command follows a `yank', just run `yank-pop'.
+If this command follows a `paredit-wrap-sexp', or any other paredit
+  wrapping command (see `paredit-wrap-commands'), run `yank' and
+  reindent the enclosing S-expression.
+If this command is repeated, run `yank-pop' and reindent the enclosing
+  S-expression.
+
+The argument is passed on to `yank' or `yank-pop'; see their
+  documentation for details."
+  (interactive "*p")
+  (cond ((eq last-command 'yank)
+         (yank-pop argument))
+        ((memq last-command paredit-wrap-commands)
+         (yank argument)
+         ;; `yank' futzes with `this-command'.
+         (setq this-command 'paredit-yank-pop)
+         (save-excursion (backward-up-list) (indent-sexp)))
+        ((eq last-command 'paredit-yank-pop)
+         ;; Pretend we just did a `yank', so that we can use
+         ;; `yank-pop' without duplicating its definition.
+         (setq last-command 'yank)
+         (yank-pop argument)
+         ;; Return to our original state.
+         (setq last-command 'paredit-yank-pop)
+         (setq this-command 'paredit-yank-pop)
+         (save-excursion (backward-up-list) (indent-sexp)))
+        (t (error "Last command was not a yank or a wrap: %s" last-command))))
+\f
+(defun paredit-splice-sexp (&optional argument)
+  "Splice the list that the point is on by removing its delimiters.
+With a prefix argument as in `C-u', kill all S-expressions backward in
+  the current list before splicing all S-expressions forward into the
+  enclosing list.
+With two prefix arguments as in `C-u C-u', kill all S-expressions
+  forward in the current list before splicing all S-expressions
+  backward into the enclosing list.
+With a numerical prefix argument N, kill N S-expressions backward in
+  the current list before splicing the remaining S-expressions into the
+  enclosing list.  If N is negative, kill forward.
+Inside a string, unescape all backslashes, or signal an error if doing
+  so would invalidate the buffer's structure."
+  (interactive "P")
+  (if (paredit-in-string-p)
+      (paredit-splice-string argument)
+      (save-excursion
+        (paredit-kill-surrounding-sexps-for-splice argument)
+        (let ((end (point)))
+          (backward-up-list)            ; Go up to the beginning...
+          (save-excursion
+            (forward-char 1)            ; (Skip over leading whitespace
+            (paredit-skip-whitespace t end)
+            (setq end (point)))         ;   for the `delete-region'.)
+          (let ((indent-start nil) (indent-end nil))
+            (save-excursion
+              (setq indent-start (point))
+              (forward-sexp)            ; Go forward an expression, to
+              (backward-delete-char 1)  ;   delete the end delimiter.
+              (setq indent-end (point)))
+            (delete-region (point) end) ; ...to delete the open char.
+            ;; Reindent only the region we preserved.
+            (indent-region indent-start indent-end nil))))))
+
+(defun paredit-kill-surrounding-sexps-for-splice (argument)
+  (cond ((or (paredit-in-string-p)
+             (paredit-in-comment-p))
+         (error "Invalid context for splicing S-expressions."))
+        ((or (not argument) (eq argument 0)) nil)
+        ((or (numberp argument) (eq argument '-))
+         ;; Kill S-expressions before/after the point by saving the
+         ;; point, moving across them, and killing the region.
+         (let* ((argument (if (eq argument '-) -1 argument))
+                (saved (paredit-point-at-sexp-boundary (- argument))))
+           (goto-char saved)
+           (paredit-ignore-sexp-errors (backward-sexp argument))
+           (paredit-hack-kill-region saved (point))))
+        ((consp argument)
+         (let ((v (car argument)))
+           (if (= v 4)                  ;One `C-u'.
+               ;; Move backward until we hit the open paren; then
+               ;; kill that selected region.
+               (let ((end (point)))
+                 (paredit-ignore-sexp-errors
+                   (while (not (bobp))
+                     (backward-sexp)))
+                 (paredit-hack-kill-region (point) end))
+               ;; Move forward until we hit the close paren; then
+               ;; kill that selected region.
+               (let ((beginning (point)))
+                 (paredit-ignore-sexp-errors
+                   (while (not (eobp))
+                     (forward-sexp)))
+                 (paredit-hack-kill-region beginning (point))))))
+        (t (error "Bizarre prefix argument `%s'." argument))))
+\f
+(defun paredit-splice-sexp-killing-backward (&optional n)
+  "Splice the list the point is on by removing its delimiters, and
+  also kill all S-expressions before the point in the current list.
+With a prefix argument N, kill only the preceding N S-expressions."
+  (interactive "P")
+  (paredit-splice-sexp (if n
+                           (prefix-numeric-value n)
+                           '(4))))
+
+(defun paredit-splice-sexp-killing-forward (&optional n)
+  "Splice the list the point is on by removing its delimiters, and
+  also kill all S-expressions after the point in the current list.
+With a prefix argument N, kill only the following N S-expressions."
+  (interactive "P")
+  (paredit-splice-sexp (if n
+                           (- (prefix-numeric-value n))
+                           '(16))))
+
+(defun paredit-raise-sexp (&optional argument)
+  "Raise the following S-expression in a tree, deleting its siblings.
+With a prefix argument N, raise the following N S-expressions.  If N
+  is negative, raise the preceding N S-expressions.
+If the point is on an S-expression, such as a string or a symbol, not
+  between them, that S-expression is considered to follow the point."
+  (interactive "P")
+  (save-excursion
+    (cond ((paredit-in-string-p)
+           (goto-char (car (paredit-string-start+end-points))))
+          ((paredit-in-char-p)
+           (backward-sexp))
+          ((paredit-in-comment-p)
+           (error "No S-expression to raise in comment.")))
+    ;; Select the S-expressions we want to raise in a buffer substring.
+    (let* ((n (prefix-numeric-value argument))
+           (bound (scan-sexps (point) n))
+           (sexps
+            (if (< n 0)
+                (buffer-substring bound (paredit-point-at-sexp-end))
+                (buffer-substring (paredit-point-at-sexp-start) bound))))
+      ;; Move up to the list we're raising those S-expressions out of and
+      ;; delete it.
+      (backward-up-list)
+      (delete-region (point) (scan-sexps (point) 1))
+      (let* ((indent-start (point))
+             (indent-end (save-excursion (insert sexps) (point))))
+        (indent-region indent-start indent-end nil)))))
+\f
+;;; The effects of convolution on the surrounding whitespace are pretty
+;;; random.  If you have better suggestions, please let me know.
+
+(defun paredit-convolute-sexp (&optional n)
+  "Convolute S-expressions.
+Save the S-expressions preceding point and delete them.
+Splice the S-expressions following point.
+Wrap the enclosing list in a new list prefixed by the saved text.
+With a prefix argument N, move up N lists before wrapping."
+  (interactive "p")
+  (paredit-lose-if-not-in-sexp 'paredit-convolute-sexp)
+  ;; Make sure we can move up before destroying anything.
+  (save-excursion (backward-up-list n) (backward-up-list))
+  (let (open close)                     ;++ Is this a good idea?
+    (let ((prefix
+           (let ((end (point)))
+             (paredit-ignore-sexp-errors
+               (while (not (bobp)) (backward-sexp)))
+             (prog1 (buffer-substring (point) end)
+               (backward-up-list)
+               (save-excursion (forward-sexp)
+                               (setq close (char-before))
+                               (backward-delete-char 1))
+               (setq open (char-after))
+               (delete-region (point) end)
+               ;; I'm not sure this makes sense...
+               (if (not (eolp)) (just-one-space))))))
+      (backward-up-list n)
+      (paredit-insert-pair 1 open close 'goto-char)
+      (insert prefix)
+      ;; I'm not sure this makes sense either...
+      (if (not (eolp)) (just-one-space))
+      (save-excursion
+        (backward-up-list)
+        (paredit-ignore-sexp-errors (indent-sexp))))))
+\f
+(defun paredit-splice-string (argument)
+  (let ((original-point (point))
+        (start+end (paredit-string-start+end-points)))
+    (let ((start (car start+end))
+          (end (cdr start+end)))
+      ;; START and END both lie before the respective quote
+      ;; characters, which we want to delete; thus we increment START
+      ;; by one to extract the string, and we increment END by one to
+      ;; delete the string.
+      (let* ((escaped-string
+              (cond ((not (consp argument))
+                     (buffer-substring (1+ start) end))
+                    ((= 4 (car argument))
+                     (buffer-substring original-point end))
+                    (t
+                     (buffer-substring (1+ start) original-point))))
+             (unescaped-string
+              (paredit-unescape-string escaped-string)))
+        (if (not unescaped-string)
+            (error "Unspliceable string.")
+          (save-excursion
+            (goto-char start)
+            (delete-region start (1+ end))
+            (insert unescaped-string))
+          (if (not (and (consp argument)
+                        (= 4 (car argument))))
+              (goto-char (- original-point 1))))))))
+
+(defun paredit-unescape-string (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (while (and (not (eobp))
+                ;; nil -> no bound; t -> no errors.
+                (search-forward "\\" nil t))
+      (delete-char -1)
+      (forward-char))
+    (paredit-handle-sexp-errors
+        (progn (scan-sexps (point-min) (point-max))
+               (buffer-string))
+      nil)))
+\f
+;;;; Slurpage & Barfage
+
+(defun paredit-forward-slurp-sexp ()
+  "Add the S-expression following the current list into that list
+  by moving the closing delimiter.
+Automatically reindent the newly slurped S-expression with respect to
+  its new enclosing form.
+If in a string, move the opening double-quote forward by one
+  S-expression and escape any intervening characters as necessary,
+  without altering any indentation or formatting."
+  (interactive)
+  (save-excursion
+    (cond ((or (paredit-in-comment-p)
+               (paredit-in-char-p))
+           (error "Invalid context for slurping S-expressions."))
+          ((paredit-in-string-p)
+           (paredit-forward-slurp-into-string))
+          (t
+           (paredit-forward-slurp-into-list)))))
+
+(defun paredit-forward-slurp-into-list ()
+  (up-list)                             ; Up to the end of the list to
+  (let ((close (char-before)))          ;   save and delete the closing
+    (backward-delete-char 1)            ;   delimiter.
+    (let ((start (point)))
+      (catch 'return                    ; Go to the end of the desired
+        (while t                        ;   S-expression, going up a
+          (paredit-handle-sexp-errors   ;   list if it's not in this,
+              (progn (forward-sexp) (throw 'return nil))
+            (up-list)
+            (setq close                 ; adjusting for mixed
+                  (prog1 (char-before)  ;   delimiters as necessary,
+                    (backward-delete-char 1)
+                    (insert close))))))
+      (insert close)                    ; to insert that delimiter.
+      (indent-region start (point) nil))))
+
+(defun paredit-forward-slurp-into-string ()
+  (goto-char (1+ (cdr (paredit-string-start+end-points))))
+  ;; Signal any errors that we might get first, before mucking with the
+  ;; buffer's contents.
+  (save-excursion (forward-sexp))
+  (let ((close (char-before)))
+    (backward-delete-char 1)
+    (paredit-forward-for-quote (save-excursion (forward-sexp) (point)))
+    (insert close)))
+
+(defun paredit-forward-barf-sexp ()
+  "Remove the last S-expression in the current list from that list
+  by moving the closing delimiter.
+Automatically reindent the newly barfed S-expression with respect to
+  its new enclosing form."
+  (interactive)
+  (paredit-lose-if-not-in-sexp 'paredit-forward-barf-sexp)
+  (save-excursion
+    (up-list)                           ; Up to the end of the list to
+    (let ((close (char-before)))        ;   save and delete the closing
+      (backward-delete-char 1)          ;   delimiter.
+      (paredit-ignore-sexp-errors       ; Go back to where we want to
+        (backward-sexp))                ;   insert the delimiter.
+      (paredit-skip-whitespace nil)     ; Skip leading whitespace.
+      (cond ((bobp)
+             (error "Barfing all subexpressions with no open-paren?"))
+            ((paredit-in-comment-p)     ; Don't put the close-paren in
+             (newline)))                ;   a comment.
+      (insert close))
+    ;; Reindent all of the newly barfed S-expressions.
+    (paredit-forward-and-indent)))
+\f
+(defun paredit-backward-slurp-sexp ()
+  "Add the S-expression preceding the current list into that list
+  by moving the closing delimiter.
+Automatically reindent the whole form into which new S-expression was
+  slurped.
+If in a string, move the opening double-quote backward by one
+  S-expression and escape any intervening characters as necessary,
+  without altering any indentation or formatting."
+  (interactive)
+  (save-excursion
+    (cond ((or (paredit-in-comment-p)
+               (paredit-in-char-p))
+           (error "Invalid context for slurping S-expressions."))
+          ((paredit-in-string-p)
+           (paredit-backward-slurp-into-string))
+          (t
+           (paredit-backward-slurp-into-list)))))
+
+(defun paredit-backward-slurp-into-list ()
+  (backward-up-list)
+  (let ((open (char-after)))
+    (delete-char 1)
+    (catch 'return
+      (while t
+        (paredit-handle-sexp-errors
+            (progn (backward-sexp) (throw 'return nil))
+          (backward-up-list)
+          (setq open
+                (prog1 (char-after)
+                  (save-excursion (insert open) (delete-char 1)))))))
+    (insert open))
+  ;; Reindent the line at the beginning of wherever we inserted the
+  ;; opening delimiter, and then indent the whole S-expression.
+  (backward-up-list)
+  (lisp-indent-line)
+  (indent-sexp))
+
+(defun paredit-backward-slurp-into-string ()
+  (goto-char (car (paredit-string-start+end-points)))
+  ;; Signal any errors that we might get first, before mucking with the
+  ;; buffer's contents.
+  (save-excursion (backward-sexp))
+  (let ((open (char-after))
+        (target (point)))
+    (delete-char 1)
+    (backward-sexp)
+    (insert open)
+    (paredit-forward-for-quote target)))
+
+(defun paredit-backward-barf-sexp ()
+  "Remove the first S-expression in the current list from that list
+  by moving the closing delimiter.
+Automatically reindent the barfed S-expression and the form from which
+  it was barfed."
+  (interactive)
+  (paredit-lose-if-not-in-sexp 'paredit-backward-barf-sexp)
+  (save-excursion
+    (backward-up-list)
+    (let ((open (char-after)))
+      (delete-char 1)
+      (paredit-ignore-sexp-errors
+        (paredit-forward-and-indent))
+      (while (progn (paredit-skip-whitespace t)
+                    (eq (char-after) ?\; ))
+        (forward-line 1))
+      (if (eobp)
+          (error "Barfing all subexpressions with no close-paren?"))
+      ;** Don't use `insert' here.  Consider, e.g., barfing from
+      ;**   (foo|)
+      ;** and how `save-excursion' works.
+      (insert-before-markers open))
+    (backward-up-list)
+    (lisp-indent-line)
+    (indent-sexp)))
+\f
+;;;; Splitting & Joining
+
+(defun paredit-split-sexp ()
+  "Split the list or string the point is on into two."
+  (interactive)
+  (cond ((paredit-in-string-p)
+         (insert "\"")
+         (save-excursion (insert " \"")))
+        ((or (paredit-in-comment-p)
+             (paredit-in-char-p))
+         (error "Invalid context for splitting S-expression."))
+        (t (let ((open  (save-excursion (backward-up-list)
+                                        (char-after)))
+                 (close (save-excursion (up-list)
+                                        (char-before))))
+             (delete-horizontal-space)
+             (insert close)
+             (save-excursion (insert ?\ )
+                             (insert open)
+                             (backward-char)
+                             (indent-sexp))))))
+
+(defun paredit-join-sexps ()
+  "Join the S-expressions adjacent on either side of the point.
+Both must be lists, strings, or atoms; error if there is a mismatch."
+  (interactive)
+  ;++ How ought this to handle comments intervening symbols or strings?
+  (save-excursion
+    (if (or (paredit-in-comment-p)
+            (paredit-in-string-p)
+            (paredit-in-char-p))
+        (error "Invalid context for joining S-expressions.")
+      (let ((left-point  (paredit-point-at-sexp-end))
+            (right-point (paredit-point-at-sexp-start)))
+        (let ((left-char (char-before left-point))
+              (right-char (char-after right-point)))
+          (let ((left-syntax (char-syntax left-char))
+                (right-syntax (char-syntax right-char)))
+            (cond ((< right-point left-point)
+                   (error "Can't join a datum with itself."))
+                  ((and (eq left-syntax  ?\) )
+                        (eq right-syntax ?\( )
+                        (eq left-char (matching-paren right-char))
+                        (eq right-char (matching-paren left-char)))
+                   ;; Leave intermediate formatting alone.
+                   (goto-char right-point)
+                   (delete-char 1)
+                   (goto-char left-point)
+                   (backward-delete-char 1)
+                   ;; Heuristic kludge: (foo)(bar) => (foo bar).
+                   (if (and (= left-point right-point)
+                            (not (or (eq ?\  (char-syntax (char-before)))
+                                     (eq ?\  (char-syntax (char-after))))))
+                       (insert ?\  ))
+                   (backward-up-list)
+                   (indent-sexp))
+                  ((and (eq left-syntax  ?\" )
+                        (eq right-syntax ?\" ))
+                   ;; Delete any intermediate formatting.
+                   (delete-region (1- left-point) (1+ right-point)))
+                  ((and (memq left-syntax  '(?w ?_)) ; Word or symbol
+                        (memq right-syntax '(?w ?_)))
+                   (delete-region left-point right-point))
+                  (t
+                   (error "Mismatched S-expressions to join.")))))))))
+\f
+;;;; Variations on the Lurid Theme
+
+;;; I haven't the imagination to concoct clever names for these.
+
+(defun paredit-add-to-previous-list ()
+  "Add the S-expression following point to the list preceding point."
+  (interactive)
+  (paredit-lose-if-not-in-sexp 'paredit-add-to-previous-list)
+  (save-excursion
+    (backward-down-list)
+    (paredit-forward-slurp-sexp)))
+
+(defun paredit-add-to-next-list ()
+  "Add the S-expression preceding point to the list following point.
+If no S-expression precedes point, move up the tree until one does."
+  (interactive)
+  (paredit-lose-if-not-in-sexp 'paredit-add-to-next-list)
+  (save-excursion
+    (down-list)
+    (paredit-backward-slurp-sexp)))
+
+(defun paredit-join-with-previous-list ()
+  "Join the list the point is on with the previous list in the buffer."
+  (interactive)
+  (paredit-lose-if-not-in-sexp 'paredit-join-with-previous-list)
+  (save-excursion
+    (while (paredit-handle-sexp-errors (save-excursion (backward-sexp) nil)
+             (backward-up-list)
+             t))
+    (paredit-join-sexps)))
+
+(defun paredit-join-with-next-list ()
+  "Join the list the point is on with the next list in the buffer."
+  (interactive)
+  (paredit-lose-if-not-in-sexp 'paredit-join-with-next-list)
+  (save-excursion
+    (while (paredit-handle-sexp-errors (save-excursion (forward-sexp) nil)
+             (up-list)
+             t))
+    (paredit-join-sexps)))
+\f
+;;;; Utilities
+
+(defun paredit-in-string-escape-p ()
+  "True if the point is on a character escape of a string.
+This is true only if the character is preceded by an odd number of
+  backslashes.
+This assumes that `paredit-in-string-p' has already returned true."
+  (let ((oddp nil))
+    (save-excursion
+      (while (eq (char-before) ?\\ )
+        (setq oddp (not oddp))
+        (backward-char)))
+    oddp))
+
+(defun paredit-in-char-p (&optional position)
+  "True if point is on a character escape outside a string."
+  (save-excursion
+    (goto-char (or position (point)))
+    (paredit-in-string-escape-p)))
+
+(defun paredit-indent-sexps ()
+  "If in a list, indent all following S-expressions in the list."
+  (let* ((start (point))
+         (end (paredit-handle-sexp-errors (progn (up-list) (point)) nil)))
+    (if end
+        (indent-region start end nil))))
+
+(defun paredit-forward-and-indent ()
+  "Move forward an S-expression, indenting it with `indent-region'."
+  (let ((start (point)))
+    (forward-sexp)
+    (indent-region start (point) nil)))
+
+(defun paredit-skip-whitespace (trailing-p &optional limit)
+  "Skip past any whitespace, or until the point LIMIT is reached.
+If TRAILING-P is nil, skip leading whitespace; otherwise, skip trailing
+  whitespace."
+  (funcall (if trailing-p 'skip-chars-forward 'skip-chars-backward)
+           " \t\n\f"  ; This should skip using the syntax table, but LF
+           limit))    ; is a comment end, not newline, in Lisp mode.
+
+(defalias 'paredit-region-active-p
+  (xcond ((paredit-xemacs-p) 'region-active-p)
+         ((paredit-gnu-emacs-p)
+          (lambda ()
+            (and mark-active transient-mark-mode)))))
+
+(defun paredit-hack-kill-region (start end)
+  "Kill the region between START and END.
+Do not append to any current kill, and
+ do not let the next kill append to this one."
+  (interactive "r")                     ;Eh, why not?
+  ;; KILL-REGION sets THIS-COMMAND to tell the next kill that the last
+  ;; command was a kill.  It also checks LAST-COMMAND to see whether it
+  ;; should append.  If we bind these locally, any modifications to
+  ;; THIS-COMMAND will be masked, and it will not see LAST-COMMAND to
+  ;; indicate that it should append.
+  (let ((this-command nil)
+        (last-command nil))
+    (kill-region start end)))
+\f
+;;;;; S-expression Parsing Utilities
+
+;++ These routines redundantly traverse S-expressions a great deal.
+;++ If performance issues arise, this whole section will probably have
+;++ to be refactored to preserve the state longer, like paredit.scm
+;++ does, rather than to traverse the definition N times for every key
+;++ stroke as it presently does.
+
+(defun paredit-current-parse-state ()
+  "Return parse state of point from beginning of defun."
+  (let ((point (point)))
+    (beginning-of-defun)
+    ;; Calling PARSE-PARTIAL-SEXP will advance the point to its second
+    ;; argument (unless parsing stops due to an error, but we assume it
+    ;; won't in paredit-mode).
+    (parse-partial-sexp (point) point)))
+
+(defun paredit-in-string-p (&optional state)
+  "True if the parse state is within a double-quote-delimited string.
+If no parse state is supplied, compute one from the beginning of the
+  defun to the point."
+  ;; 3. non-nil if inside a string (the terminator character, really)
+  (and (nth 3 (or state (paredit-current-parse-state)))
+       t))
+
+(defun paredit-string-start+end-points (&optional state)
+  "Return a cons of the points of open and close quotes of the string.
+The string is determined from the parse state STATE, or the parse state
+  from the beginning of the defun to the point.
+This assumes that `paredit-in-string-p' has already returned true, i.e.
+  that the point is already within a string."
+  (save-excursion
+    ;; 8. character address of start of comment or string; nil if not
+    ;;    in one
+    (let ((start (nth 8 (or state (paredit-current-parse-state)))))
+      (goto-char start)
+      (forward-sexp 1)
+      (cons start (1- (point))))))
+
+(defun paredit-in-comment-p (&optional state)
+  "True if parse state STATE is within a comment.
+If no parse state is supplied, compute one from the beginning of the
+  defun to the point."
+  ;; 4. nil if outside a comment, t if inside a non-nestable comment,
+  ;;    else an integer (the current comment nesting)
+  (and (nth 4 (or state (paredit-current-parse-state)))
+       t))
+\f
+(defun paredit-point-at-sexp-boundary (n)
+  (cond ((< n 0) (paredit-point-at-sexp-start))
+        ((= n 0) (point))
+        ((> n 0) (paredit-point-at-sexp-end))))
+
+(defun paredit-point-at-sexp-start ()
+  (save-excursion
+    (forward-sexp)
+    (backward-sexp)
+    (point)))
+
+(defun paredit-point-at-sexp-end ()
+  (save-excursion
+    (backward-sexp)
+    (forward-sexp)
+    (point)))
+
+(defun paredit-lose-if-not-in-sexp (command)
+  (if (or (paredit-in-string-p)
+          (paredit-in-comment-p)
+          (paredit-in-char-p))
+      (error "Invalid context for command `%s'." command)))
+
+(defun paredit-check-region (start end)
+  "Signal an error if text between `start' and `end' is unbalanced."
+  ;; `narrow-to-region' will move the point, so avoid calling it if we
+  ;; don't need to.  We don't want to use `save-excursion' because we
+  ;; want the point to move if `check-parens' reports an error.
+  (if (not (paredit-region-ok-p start end))
+      (save-restriction
+        (narrow-to-region start end)
+        (check-parens))))
+
+(defun paredit-region-ok-p (start end)
+  "Return true iff the region between `start' and `end' is balanced.
+This is independent of context -- it doesn't check what state the
+  text at `start' is in."
+  (save-excursion
+    (paredit-handle-sexp-errors
+        (progn
+          (save-restriction
+            (narrow-to-region start end)
+            (scan-sexps (point-min) (point-max)))
+          t)
+      nil)))
+
+(defun paredit-current-indentation ()
+  (save-excursion
+    (back-to-indentation)
+    (current-column)))
+\f
+;;;; Initialization
+
+(paredit-define-keys)
+(paredit-annotate-mode-with-examples)
+(paredit-annotate-functions-with-examples)
+
+(provide 'paredit)
+
+;;; Local Variables:
+;;; outline-regexp: "\f\n;;;;+"
+;;; End:
+
+;;; paredit.el ends here
diff --git a/elisp/local/rainbow-mode.el b/elisp/local/rainbow-mode.el
new file mode 100644 (file)
index 0000000..e23bacd
--- /dev/null
@@ -0,0 +1,469 @@
+;;; rainbow-mode.el --- Colorize color names in buffers
+
+;; Copyright (C) 2010-2012 Free Software Foundation, Inc
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: faces
+;; Version: 0.7
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This minor mode sets background color to strings that match color
+;; names, e.g. #0000ff is displayed in white with a blue background.
+;;
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl))
+
+(require 'regexp-opt)
+(require 'faces)
+(require 'color)
+
+(unless (require 'xterm-color nil t)
+  (require 'ansi-color))
+
+(defgroup rainbow nil
+  "Show color strings with a background color."
+  :tag "Rainbow"
+  :group 'help)
+
+;; Hexadecimal colors
+(defvar rainbow-hexadecimal-colors-font-lock-keywords
+  '(("[^&]\\(#\\(?:[0-9a-fA-F]\\{3\\}\\)+\\{1,4\\}\\)"
+     (1 (rainbow-colorize-itself 1)))
+    ("^\\(#\\(?:[0-9a-fA-F]\\{3\\}\\)+\\{1,4\\}\\)"
+     (0 (rainbow-colorize-itself)))
+    ("[Rr][Gg][Bb]:[0-9a-fA-F]\\{1,4\\}/[0-9a-fA-F]\\{1,4\\}/[0-9a-fA-F]\\{1,4\\}"
+     (0 (rainbow-colorize-itself)))
+    ("[Rr][Gg][Bb][Ii]:[0-9.]+/[0-9.]+/[0-9.]+"
+     (0 (rainbow-colorize-itself)))
+    ("\\(?:[Cc][Ii][Ee]\\(?:[Xx][Yy][Zz]\\|[Uu][Vv][Yy]\\|[Xx][Yy][Yy]\\|[Ll][Aa][Bb]\\|[Ll][Uu][Vv]\\)\\|[Tt][Ee][Kk][Hh][Vv][Cc]\\):[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?/[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?/[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?"
+     (0 (rainbow-colorize-itself))))
+  "Font-lock keywords to add for hexadecimal colors.")
+
+;; rgb() colors
+(defvar rainbow-html-rgb-colors-font-lock-keywords
+  '(("rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)"
+     (0 (rainbow-colorize-rgb)))
+    ("rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+     (0 (rainbow-colorize-rgb)))
+    ("hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
+     (0 (rainbow-colorize-hsl)))
+    ("hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+     (0 (rainbow-colorize-hsl))))
+  "Font-lock keywords to add for RGB colors.")
+
+;; HTML colors name
+(defvar rainbow-html-colors-font-lock-keywords nil
+  "Font-lock keywords to add for HTML colors.")
+(make-variable-buffer-local 'rainbow-html-colors-font-lock-keywords)
+
+(defcustom rainbow-html-colors-alist
+  '(("AliceBlue" . "#F0F8FF")
+    ("AntiqueWhite" . "#FAEBD7")
+    ("Aqua" . "#00FFFF")
+    ("Aquamarine" . "#7FFFD4")
+    ("Azure" . "#F0FFFF")
+    ("Beige" . "#F5F5DC")
+    ("Bisque" . "#FFE4C4")
+    ("Black" . "#000000")
+    ("BlanchedAlmond" . "#FFEBCD")
+    ("Blue" . "#0000FF")
+    ("BlueViolet" . "#8A2BE2")
+    ("Brown" . "#A52A2A")
+    ("BurlyWood" . "#DEB887")
+    ("CadetBlue" . "#5F9EA0")
+    ("Chartreuse" . "#7FFF00")
+    ("Chocolate" . "#D2691E")
+    ("Coral" . "#FF7F50")
+    ("CornflowerBlue" . "#6495ED")
+    ("Cornsilk" . "#FFF8DC")
+    ("Crimson" . "#DC143C")
+    ("Cyan" . "#00FFFF")
+    ("DarkBlue" . "#00008B")
+    ("DarkCyan" . "#008B8B")
+    ("DarkGoldenRod" . "#B8860B")
+    ("DarkGray" . "#A9A9A9")
+    ("DarkGrey" . "#A9A9A9")
+    ("DarkGreen" . "#006400")
+    ("DarkKhaki" . "#BDB76B")
+    ("DarkMagenta" . "#8B008B")
+    ("DarkOliveGreen" . "#556B2F")
+    ("Darkorange" . "#FF8C00")
+    ("DarkOrchid" . "#9932CC")
+    ("DarkRed" . "#8B0000")
+    ("DarkSalmon" . "#E9967A")
+    ("DarkSeaGreen" . "#8FBC8F")
+    ("DarkSlateBlue" . "#483D8B")
+    ("DarkSlateGray" . "#2F4F4F")
+    ("DarkSlateGrey" . "#2F4F4F")
+    ("DarkTurquoise" . "#00CED1")
+    ("DarkViolet" . "#9400D3")
+    ("DeepPink" . "#FF1493")
+    ("DeepSkyBlue" . "#00BFFF")
+    ("DimGray" . "#696969")
+    ("DimGrey" . "#696969")
+    ("DodgerBlue" . "#1E90FF")
+    ("FireBrick" . "#B22222")
+    ("FloralWhite" . "#FFFAF0")
+    ("ForestGreen" . "#228B22")
+    ("Fuchsia" . "#FF00FF")
+    ("Gainsboro" . "#DCDCDC")
+    ("GhostWhite" . "#F8F8FF")
+    ("Gold" . "#FFD700")
+    ("GoldenRod" . "#DAA520")
+    ("Gray" . "#808080")
+    ("Grey" . "#808080")
+    ("Green" . "#008000")
+    ("GreenYellow" . "#ADFF2F")
+    ("HoneyDew" . "#F0FFF0")
+    ("HotPink" . "#FF69B4")
+    ("IndianRed" . "#CD5C5C")
+    ("Indigo" . "#4B0082")
+    ("Ivory" . "#FFFFF0")
+    ("Khaki" . "#F0E68C")
+    ("Lavender" . "#E6E6FA")
+    ("LavenderBlush" . "#FFF0F5")
+    ("LawnGreen" . "#7CFC00")
+    ("LemonChiffon" . "#FFFACD")
+    ("LightBlue" . "#ADD8E6")
+    ("LightCoral" . "#F08080")
+    ("LightCyan" . "#E0FFFF")
+    ("LightGoldenRodYellow" . "#FAFAD2")
+    ("LightGray" . "#D3D3D3")
+    ("LightGrey" . "#D3D3D3")
+    ("LightGreen" . "#90EE90")
+    ("LightPink" . "#FFB6C1")
+    ("LightSalmon" . "#FFA07A")
+    ("LightSeaGreen" . "#20B2AA")
+    ("LightSkyBlue" . "#87CEFA")
+    ("LightSlateGray" . "#778899")
+    ("LightSlateGrey" . "#778899")
+    ("LightSteelBlue" . "#B0C4DE")
+    ("LightYellow" . "#FFFFE0")
+    ("Lime" . "#00FF00")
+    ("LimeGreen" . "#32CD32")
+    ("Linen" . "#FAF0E6")
+    ("Magenta" . "#FF00FF")
+    ("Maroon" . "#800000")
+    ("MediumAquaMarine" . "#66CDAA")
+    ("MediumBlue" . "#0000CD")
+    ("MediumOrchid" . "#BA55D3")
+    ("MediumPurple" . "#9370D8")
+    ("MediumSeaGreen" . "#3CB371")
+    ("MediumSlateBlue" . "#7B68EE")
+    ("MediumSpringGreen" . "#00FA9A")
+    ("MediumTurquoise" . "#48D1CC")
+    ("MediumVioletRed" . "#C71585")
+    ("MidnightBlue" . "#191970")
+    ("MintCream" . "#F5FFFA")
+    ("MistyRose" . "#FFE4E1")
+    ("Moccasin" . "#FFE4B5")
+    ("NavajoWhite" . "#FFDEAD")
+    ("Navy" . "#000080")
+    ("OldLace" . "#FDF5E6")
+    ("Olive" . "#808000")
+    ("OliveDrab" . "#6B8E23")
+    ("Orange" . "#FFA500")
+    ("OrangeRed" . "#FF4500")
+    ("Orchid" . "#DA70D6")
+    ("PaleGoldenRod" . "#EEE8AA")
+    ("PaleGreen" . "#98FB98")
+    ("PaleTurquoise" . "#AFEEEE")
+    ("PaleVioletRed" . "#D87093")
+    ("PapayaWhip" . "#FFEFD5")
+    ("PeachPuff" . "#FFDAB9")
+    ("Peru" . "#CD853F")
+    ("Pink" . "#FFC0CB")
+    ("Plum" . "#DDA0DD")
+    ("PowderBlue" . "#B0E0E6")
+    ("Purple" . "#800080")
+    ("Red" . "#FF0000")
+    ("RosyBrown" . "#BC8F8F")
+    ("RoyalBlue" . "#4169E1")
+    ("SaddleBrown" . "#8B4513")
+    ("Salmon" . "#FA8072")
+    ("SandyBrown" . "#F4A460")
+    ("SeaGreen" . "#2E8B57")
+    ("SeaShell" . "#FFF5EE")
+    ("Sienna" . "#A0522D")
+    ("Silver" . "#C0C0C0")
+    ("SkyBlue" . "#87CEEB")
+    ("SlateBlue" . "#6A5ACD")
+    ("SlateGray" . "#708090")
+    ("SlateGrey" . "#708090")
+    ("Snow" . "#FFFAFA")
+    ("SpringGreen" . "#00FF7F")
+    ("SteelBlue" . "#4682B4")
+    ("Tan" . "#D2B48C")
+    ("Teal" . "#008080")
+    ("Thistle" . "#D8BFD8")
+    ("Tomato" . "#FF6347")
+    ("Turquoise" . "#40E0D0")
+    ("Violet" . "#EE82EE")
+    ("Wheat" . "#F5DEB3")
+    ("White" . "#FFFFFF")
+    ("WhiteSmoke" . "#F5F5F5")
+    ("Yellow" . "#FFFF00")
+    ("YellowGreen" . "#9ACD32"))
+  "Alist of HTML colors.
+Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR)."
+  :group 'rainbow)
+
+(defcustom rainbow-html-colors-major-mode-list
+  '(html-mode css-mode php-mode nxml-mode xml-mode)
+  "List of major mode where HTML colors are enabled when
+`rainbow-html-colors' is set to auto."
+  :group 'rainbow)
+
+(defcustom rainbow-html-colors 'auto
+  "When to enable HTML colors.
+If set to t, the HTML colors will be enabled.  If set to nil, the
+HTML colors will not be enabled.  If set to auto, the HTML colors
+will be enabled if a major mode has been detected from the
+`rainbow-html-colors-major-mode-list'."
+  :group 'rainbow)
+
+;; X colors
+(defvar rainbow-x-colors-font-lock-keywords
+  `((,(regexp-opt (x-defined-colors) 'words)
+     (0 (rainbow-colorize-itself))))
+  "Font-lock keywords to add for X colors.")
+
+(defcustom rainbow-x-colors-major-mode-list
+  '(emacs-lisp-mode lisp-interaction-mode c-mode c++-mode java-mode)
+  "List of major mode where X colors are enabled when
+`rainbow-x-colors' is set to auto."
+  :group 'rainbow)
+
+(defcustom rainbow-x-colors 'auto
+  "When to enable X colors.
+If set to t, the X colors will be enabled.  If set to nil, the
+X colors will not be enabled.  If set to auto, the X colors
+will be enabled if a major mode has been detected from the
+`rainbow-x-colors-major-mode-list'."
+  :group 'rainbow)
+
+;; LaTeX colors
+(defvar rainbow-latex-rgb-colors-font-lock-keywords
+  '(("{rgb}{\\([0-9.]+\\),\\([0-9.]+\\),\\([0-9.]+\\)}"
+     (0 (rainbow-colorize-rgb-float)))
+    ("{RGB}{\\([0-9]\\{1,3\\}\\),\\([0-9]\\{1,3\\}\\),\\([0-9]\\{1,3\\}\\)}"
+     (0 (rainbow-colorize-rgb)))
+    ("{HTML}{\\([0-9A-Fa-f]\\{6\\}\\)}"
+     (0 (rainbow-colorize-hexadecimal-without-sharp))))
+  "Font-lock keywords to add for LaTeX colors.")
+
+(defcustom rainbow-latex-colors-major-mode-list
+  '(latex-mode)
+  "List of major mode where LaTeX colors are enabled when
+`rainbow-x-colors' is set to auto."
+  :group 'rainbow)
+
+(defcustom rainbow-latex-colors 'auto
+  "When to enable LaTeX colors.
+If set to t, the LaTeX colors will be enabled. If set to nil, the
+LaTeX colors will not be enabled.  If set to auto, the LaTeX colors
+will be enabled if a major mode has been detected from the
+`rainbow-latex-colors-major-mode-list'."
+  :group 'rainbow)
+
+;; Shell colors
+(defvar rainbow-ansi-colors-font-lock-keywords
+  '(("\\(\\\\[eE]\\|\\\\033\\|\\\\x1[bB]\\|\033\\)\\[\\([0-9;]*m\\)"
+     (0 (rainbow-colorize-ansi))))
+  "Font-lock keywords to add for ANSI colors.")
+
+(defcustom rainbow-ansi-colors-major-mode-list
+  '(sh-mode c-mode c++-mode)
+  "List of major mode where ANSI colors are enabled when
+`rainbow-ansi-colors' is set to auto."
+  :group 'rainbow)
+
+(defcustom rainbow-ansi-colors 'auto
+  "When to enable ANSI colors.
+If set to t, the ANSI colors will be enabled. If set to nil, the
+ANSI colors will not be enabled.  If set to auto, the ANSI colors
+will be enabled if a major mode has been detected from the
+`rainbow-ansi-colors-major-mode-list'."
+  :group 'rainbow)
+
+;; Functions
+(defun rainbow-colorize-match (color &optional match)
+  "Return a matched string propertized with a face whose
+background is COLOR. The foreground is computed using
+`rainbow-color-luminance', and is either white or black."
+  (let ((match (or match 0)))
+    (put-text-property
+     (match-beginning match) (match-end match)
+     'face `((:foreground ,(if (> 0.5 (rainbow-x-color-luminance color))
+                               "white" "black"))
+             (:background ,color)))))
+
+(defun rainbow-colorize-itself (&optional match)
+  "Colorize a match with itself."
+  (rainbow-colorize-match (match-string-no-properties (or match 0)) match))
+
+(defun rainbow-colorize-hexadecimal-without-sharp ()
+  "Colorize an hexadecimal colors and prepend # to it."
+  (rainbow-colorize-match (concat "#" (match-string-no-properties 1))))
+
+(defun rainbow-colorize-by-assoc (assoc-list)
+  "Colorize a match with its association from ASSOC-LIST."
+  (rainbow-colorize-match (cdr (assoc-string (match-string-no-properties 0)
+                                             assoc-list t))))
+
+(defun rainbow-rgb-relative-to-absolute (number)
+  "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER.
+This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
+  (let ((string-length (- (length number) 1)))
+    ;; Is this a number with %?
+    (if (eq (elt number string-length) ?%)
+        (/ (* (string-to-number (substring number 0 string-length)) 255) 100)
+      (string-to-number number))))
+
+(defun rainbow-colorize-hsl ()
+  "Colorize a match with itself."
+  (let ((h (/ (string-to-number (match-string-no-properties 1)) 360.0))
+        (s (/ (string-to-number (match-string-no-properties 2)) 100.0))
+        (l (/ (string-to-number (match-string-no-properties 3)) 100.0)))
+    (rainbow-colorize-match
+     (multiple-value-bind (r g b)
+        (color-hsl-to-rgb h s l)
+       (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255))))))
+
+(defun rainbow-colorize-rgb ()
+  "Colorize a match with itself."
+  (let ((r (rainbow-rgb-relative-to-absolute (match-string-no-properties 1)))
+        (g (rainbow-rgb-relative-to-absolute (match-string-no-properties 2)))
+        (b (rainbow-rgb-relative-to-absolute (match-string-no-properties 3))))
+    (rainbow-colorize-match (format "#%02X%02X%02X" r g b))))
+
+(defun rainbow-colorize-rgb-float ()
+  "Colorize a match with itself, with relative value."
+  (let ((r (* (string-to-number (match-string-no-properties 1)) 255.0))
+        (g (* (string-to-number (match-string-no-properties 2)) 255.0))
+        (b (* (string-to-number (match-string-no-properties 3)) 255.0)))
+    (rainbow-colorize-match (format "#%02X%02X%02X" r g b))))
+
+(defun rainbow-colorize-ansi ()
+  "Return a matched string propertized with ansi color face."
+  (let ((xterm-color? (featurep 'xterm-color))
+        (string (match-string-no-properties 0))
+        color)
+    (save-match-data
+      (let* ((replaced (concat
+                        (replace-regexp-in-string
+                         "^\\(\\\\[eE]\\|\\\\033\\|\\\\x1[bB]\\)"
+                         "\033" string) "x"))
+             xterm-color-current
+             ansi-color-context
+             (applied (funcall (if xterm-color?
+                                   'xterm-color-filter
+                                 'ansi-color-apply)
+                               replaced))
+             (face-property (get-text-property
+                             0
+                             (if xterm-color? 'face 'font-lock-face)
+                             applied)))
+        (unless (listp (car face-property))
+          (setq face-property (list face-property)))
+        (setq color (funcall (if xterm-color? 'cadr 'cdr)
+                             (or (assq (if xterm-color?
+                                           :foreground
+                                         'foreground-color)
+                                       face-property)
+                                 (assq (if xterm-color?
+                                           :background
+                                         'background-color)
+                                       face-property))))))
+    (when color
+      (rainbow-colorize-match color))))
+
+(defun rainbow-color-luminance (red green blue)
+  "Calculate the luminance of color composed of RED, BLUE and GREEN.
+Return a value between 0 and 1."
+  (/ (+ (* .2126 red) (* .7152 green) (* .0722 blue)) 256))
+
+(defun rainbow-x-color-luminance (color)
+  "Calculate the luminance of a color string (e.g. \"#ffaa00\", \"blue\").
+Return a value between 0 and 1."
+  (let* ((values (x-color-values color))
+        (r (/ (car values) 256.0))
+         (g (/ (cadr values) 256.0))
+        (b (/ (caddr values) 256.0)))
+    (rainbow-color-luminance r g b)))
+
+(defun rainbow-turn-on ()
+  "Turn on raibow-mode."
+  (font-lock-add-keywords nil
+                          rainbow-hexadecimal-colors-font-lock-keywords)
+  ;; Activate X colors?
+  (when (or (eq rainbow-x-colors t)
+            (and (eq rainbow-x-colors 'auto)
+                 (memq major-mode rainbow-x-colors-major-mode-list)))
+    (font-lock-add-keywords nil
+                            rainbow-x-colors-font-lock-keywords))
+  ;; Activate LaTeX colors?
+  (when (or (eq rainbow-latex-colors t)
+            (and (eq rainbow-latex-colors 'auto)
+                 (memq major-mode rainbow-latex-colors-major-mode-list)))
+    (font-lock-add-keywords nil
+                            rainbow-latex-rgb-colors-font-lock-keywords))
+  ;; Activate ANSI colors?
+  (when (or (eq rainbow-ansi-colors t)
+            (and (eq rainbow-ansi-colors 'auto)
+                 (memq major-mode rainbow-ansi-colors-major-mode-list)))
+    (font-lock-add-keywords nil
+                            rainbow-ansi-colors-font-lock-keywords))
+  ;; Activate HTML colors?
+  (when (or (eq rainbow-html-colors t)
+            (and (eq rainbow-html-colors 'auto)
+                 (memq major-mode rainbow-html-colors-major-mode-list)))
+    (setq rainbow-html-colors-font-lock-keywords
+          `((,(regexp-opt (mapcar 'car rainbow-html-colors-alist) 'words)
+             (0 (rainbow-colorize-by-assoc rainbow-html-colors-alist)))))
+    (font-lock-add-keywords nil
+                            `(,@rainbow-html-colors-font-lock-keywords
+                              ,@rainbow-html-rgb-colors-font-lock-keywords))))
+
+(defun rainbow-turn-off ()
+  "Turn off rainbow-mode."
+  (font-lock-remove-keywords
+   nil
+   `(,@rainbow-hexadecimal-colors-font-lock-keywords
+     ,@rainbow-x-colors-font-lock-keywords
+     ,@rainbow-latex-rgb-colors-font-lock-keywords
+     ,@rainbow-html-colors-font-lock-keywords
+     ,@rainbow-html-rgb-colors-font-lock-keywords)))
+
+;;;###autoload
+(define-minor-mode rainbow-mode
+  "Colorize strings that represent colors.
+This will fontify with colors the string like \"#aabbcc\" or \"blue\"."
+  :lighter " Rbow"
+  (progn
+    (if rainbow-mode
+        (rainbow-turn-on)
+      (rainbow-turn-off))))
+
+(provide 'rainbow-mode)
+
+;;; rainbow-mode.el ends here
diff --git a/elisp/local/undo-tree.el b/elisp/local/undo-tree.el
new file mode 100644 (file)
index 0000000..d18c70d
--- /dev/null
@@ -0,0 +1,4243 @@
+;;; undo-tree.el --- Treat undo history as a tree  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2009-2012  Free Software Foundation, Inc
+
+;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
+;; Version: 0.6.3
+;; Keywords: convenience, files, undo, redo, history, tree
+;; URL: http://www.dr-qubit.org/emacs.php
+;; Repository: http://www.dr-qubit.org/git/undo-tree.git
+
+;; This file is part of Emacs.
+;;
+;; This file is free software: you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation, either version 3 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
+;; more details.
+;;
+;; You should have received a copy of the GNU General Public License along
+;; with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+;;
+;; Emacs has a powerful undo system. Unlike the standard undo/redo system in
+;; most software, it allows you to recover *any* past state of a buffer
+;; (whereas the standard undo/redo system can lose past states as soon as you
+;; redo). However, this power comes at a price: many people find Emacs' undo
+;; system confusing and difficult to use, spawning a number of packages that
+;; replace it with the less powerful but more intuitive undo/redo system.
+;;
+;; Both the loss of data with standard undo/redo, and the confusion of Emacs'
+;; undo, stem from trying to treat undo history as a linear sequence of
+;; changes. It's not. The `undo-tree-mode' provided by this package replaces
+;; Emacs' undo system with a system that treats undo history as what it is: a
+;; branching tree of changes. This simple idea allows the more intuitive
+;; behaviour of the standard undo/redo system to be combined with the power of
+;; never losing any history. An added side bonus is that undo history can in
+;; some cases be stored more efficiently, allowing more changes to accumulate
+;; before Emacs starts discarding history.
+;;
+;; The only downside to this more advanced yet simpler undo system is that it
+;; was inspired by Vim. But, after all, most successful religions steal the
+;; best ideas from their competitors!
+;;
+;;
+;; Installation
+;; ============
+;;
+;; This package has only been tested with Emacs versions 24 and CVS. It should
+;; work in Emacs versions 22 and 23 too, but will not work without
+;; modifications in earlier versions of Emacs.
+;;
+;; To install `undo-tree-mode', make sure this file is saved in a directory in
+;; your `load-path', and add the line:
+;;
+;;   (require 'undo-tree)
+;;
+;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using
+;; "M-x byte-compile-file" from within emacs).
+;;
+;; If you want to replace the standard Emacs' undo system with the
+;; `undo-tree-mode' system in all buffers, you can enable it globally by
+;; adding:
+;;
+;;   (global-undo-tree-mode)
+;;
+;; to your .emacs file.
+;;
+;;
+;; Quick-Start
+;; ===========
+;;
+;; If you're the kind of person who likes to jump in the car and drive,
+;; without bothering to first figure out whether the button on the left dips
+;; the headlights or operates the ejector seat (after all, you'll soon figure
+;; it out when you push it), then here's the minimum you need to know:
+;;
+;; `undo-tree-mode' and `global-undo-tree-mode'
+;;   Enable undo-tree mode (either in the current buffer or globally).
+;;
+;; C-_  C-/  (`undo-tree-undo')
+;;   Undo changes.
+;;
+;; M-_  C-?  (`undo-tree-redo')
+;;   Redo changes.
+;;
+;; `undo-tree-switch-branch'
+;;   Switch undo-tree branch.
+;;   (What does this mean? Better press the button and see!)
+;;
+;; C-x u  (`undo-tree-visualize')
+;;   Visualize the undo tree.
+;;   (Better try pressing this button too!)
+;;
+;; C-x r u  (`undo-tree-save-state-to-register')
+;;   Save current buffer state to register.
+;;
+;; C-x r U  (`undo-tree-restore-state-from-register')
+;;   Restore buffer state from register.
+;;
+;;
+;;
+;; In the undo-tree visualizer:
+;;
+;; <up>  p  C-p  (`undo-tree-visualize-undo')
+;;   Undo changes.
+;;
+;; <down>  n  C-n  (`undo-tree-visualize-redo')
+;;   Redo changes.
+;;
+;; <left>  b  C-b  (`undo-tree-visualize-switch-branch-left')
+;;   Switch to previous undo-tree branch.
+;;
+;; <right>  f  C-f  (`undo-tree-visualize-switch-branch-right')
+;;   Switch to next undo-tree branch.
+;;
+;; C-<up>  M-{  (`undo-tree-visualize-undo-to-x')
+;;   Undo changes up to last branch point.
+;;
+;; C-<down>  M-}  (`undo-tree-visualize-redo-to-x')
+;;   Redo changes down to next branch point.
+;;
+;; <down>  n  C-n  (`undo-tree-visualize-redo')
+;;   Redo changes.
+;;
+;; <mouse-1>  (`undo-tree-visualizer-mouse-set')
+;;   Set state to node at mouse click.
+;;
+;; t  (`undo-tree-visualizer-toggle-timestamps')
+;;   Toggle display of time-stamps.
+;;
+;; d  (`undo-tree-visualizer-toggle-diff')
+;;   Toggle diff display.
+;;
+;; s  (`undo-tree-visualizer-selection-mode')
+;;   Toggle keyboard selection mode.
+;;
+;; q  (`undo-tree-visualizer-quit')
+;;   Quit undo-tree-visualizer.
+;;
+;; C-q  (`undo-tree-visualizer-abort')
+;;   Abort undo-tree-visualizer.
+;;
+;; ,  <
+;;   Scroll left.
+;;
+;; .  >
+;;   Scroll right.
+;;
+;; <pgup>  M-v
+;;   Scroll up.
+;;
+;; <pgdown>  C-v
+;;   Scroll down.
+;;
+;;
+;;
+;; In visualizer selection mode:
+;;
+;; <up>  p  C-p  (`undo-tree-visualizer-select-previous')
+;;   Select previous node.
+;;
+;; <down>  n  C-n  (`undo-tree-visualizer-select-next')
+;;   Select next node.
+;;
+;; <left>  b  C-b  (`undo-tree-visualizer-select-left')
+;;   Select left sibling node.
+;;
+;; <right>  f  C-f  (`undo-tree-visualizer-select-right')
+;;   Select right sibling node.
+;;
+;; <pgup>  M-v
+;;   Select node 10 above.
+;;
+;; <pgdown>  C-v
+;;   Select node 10 below.
+;;
+;; <enter>  (`undo-tree-visualizer-set')
+;;   Set state to selected node and exit selection mode.
+;;
+;; s  (`undo-tree-visualizer-mode')
+;;   Exit selection mode.
+;;
+;; t  (`undo-tree-visualizer-toggle-timestamps')
+;;   Toggle display of time-stamps.
+;;
+;; d  (`undo-tree-visualizer-toggle-diff')
+;;   Toggle diff display.
+;;
+;; q  (`undo-tree-visualizer-quit')
+;;   Quit undo-tree-visualizer.
+;;
+;; C-q  (`undo-tree-visualizer-abort')
+;;   Abort undo-tree-visualizer.
+;;
+;; ,  <
+;;   Scroll left.
+;;
+;; .  >
+;;   Scroll right.
+;;
+;;
+;;
+;; Persistent undo history:
+;;
+;; Note: Requires a recent development version of Emacs checked out out from
+;;       the Emacs bzr repository. All stable versions of Emacs currently
+;;       break this feature.
+;;
+;; `undo-tree-auto-save-history' (variable)
+;;    automatically save and restore undo-tree history along with buffer
+;;    (disabled by default)
+;;
+;; `undo-tree-save-history' (command)
+;;    manually save undo history to file
+;;
+;; `undo-tree-load-history' (command)
+;;    manually load undo history from file
+;;
+;;
+;;
+;; Compressing undo history:
+;;
+;;   Undo history files cannot grow beyond the maximum undo tree size, which
+;;   is limited by `undo-limit', `undo-strong-limit' and
+;;   `undo-outer-limit'. Nevertheless, undo history files can grow quite
+;;   large. If you want to automatically compress undo history, add the
+;;   following advice to your .emacs file (replacing ".gz" with the filename
+;;   extension of your favourite compression algorithm):
+;;
+;;   (defadvice undo-tree-make-history-save-file-name
+;;     (after undo-tree activate)
+;;     (setq ad-return-value (concat ad-return-value ".gz")))
+;;
+;;
+;;
+;;
+;; Undo Systems
+;; ============
+;;
+;; To understand the different undo systems, it's easiest to consider an
+;; example. Imagine you make a few edits in a buffer. As you edit, you
+;; accumulate a history of changes, which we might visualize as a string of
+;; past buffer states, growing downwards:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o  (first edit)
+;;                                |
+;;                                |
+;;                                o  (second edit)
+;;                                |
+;;                                |
+;;                                x  (current buffer state)
+;;
+;;
+;; Now imagine that you undo the last two changes. We can visualize this as
+;; rewinding the current state back two steps:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                x  (current buffer state)
+;;                                |
+;;                                |
+;;                                o
+;;                                |
+;;                                |
+;;                                o
+;;
+;;
+;; However, this isn't a good representation of what Emacs' undo system
+;; does. Instead, it treats the undos as *new* changes to the buffer, and adds
+;; them to the history:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o  (first edit)
+;;                                |
+;;                                |
+;;                                o  (second edit)
+;;                                |
+;;                                |
+;;                                x  (buffer state before undo)
+;;                                |
+;;                                |
+;;                                o  (first undo)
+;;                                |
+;;                                |
+;;                                x  (second undo)
+;;
+;;
+;; Actually, since the buffer returns to a previous state after an undo,
+;; perhaps a better way to visualize it is to imagine the string of changes
+;; turning back on itself:
+;;
+;;        (initial buffer state)  o
+;;                                |
+;;                                |
+;;                  (first edit)  o  x  (second undo)
+;;                                |  |
+;;                                |  |
+;;                 (second edit)  o  o  (first undo)
+;;                                | /
+;;                                |/
+;;                                o  (buffer state before undo)
+;;
+;; Treating undos as new changes might seem a strange thing to do. But the
+;; advantage becomes clear as soon as we imagine what happens when you edit
+;; the buffer again. Since you've undone a couple of changes, new edits will
+;; branch off from the buffer state that you've rewound to. Conceptually, it
+;; looks like this:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o
+;;                                |\
+;;                                | \
+;;                                o  x  (new edit)
+;;                                |
+;;                                |
+;;                                o
+;;
+;; The standard undo/redo system only lets you go backwards and forwards
+;; linearly. So as soon as you make that new edit, it discards the old
+;; branch. Emacs' undo just keeps adding changes to the end of the string. So
+;; the undo history in the two systems now looks like this:
+;;
+;;            Undo/Redo:                      Emacs' undo
+;;
+;;               o                                o
+;;               |                                |
+;;               |                                |
+;;               o                                o  o
+;;               .\                               |  |\
+;;               . \                              |  | \
+;;               .  x  (new edit)                 o  o  |
+;;   (discarded  .                                | /   |
+;;     branch)   .                                |/    |
+;;               .                                o     |
+;;                                                      |
+;;                                                      |
+;;                                                      x  (new edit)
+;;
+;; Now, what if you change your mind about those undos, and decide you did
+;; like those other changes you'd made after all? With the standard undo/redo
+;; system, you're lost. There's no way to recover them, because that branch
+;; was discarded when you made the new edit.
+;;
+;; However, in Emacs' undo system, those old buffer states are still there in
+;; the undo history. You just have to rewind back through the new edit, and
+;; back through the changes made by the undos, until you reach them. Of
+;; course, since Emacs treats undos (even undos of undos!) as new changes,
+;; you're really weaving backwards and forwards through the history, all the
+;; time adding new changes to the end of the string as you go:
+;;
+;;                       o
+;;                       |
+;;                       |
+;;                       o  o     o  (undo new edit)
+;;                       |  |\    |\
+;;                       |  | \   | \
+;;                       o  o  |  |  o  (undo the undo)
+;;                       | /   |  |  |
+;;                       |/    |  |  |
+;;      (trying to get   o     |  |  x  (undo the undo)
+;;       to this state)        | /
+;;                             |/
+;;                             o
+;;
+;; So far, this is still reasonably intuitive to use. It doesn't behave so
+;; differently to standard undo/redo, except that by going back far enough you
+;; can access changes that would be lost in standard undo/redo.
+;;
+;; However, imagine that after undoing as just described, you decide you
+;; actually want to rewind right back to the initial state. If you're lucky,
+;; and haven't invoked any command since the last undo, you can just keep on
+;; undoing until you get back to the start:
+;;
+;;      (trying to get   o              x  (got there!)
+;;       to this state)  |              |
+;;                       |              |
+;;                       o  o     o     o  (keep undoing)
+;;                       |  |\    |\    |
+;;                       |  | \   | \   |
+;;                       o  o  |  |  o  o  (keep undoing)
+;;                       | /   |  |  | /
+;;                       |/    |  |  |/
+;;      (already undid   o     |  |  o  (got this far)
+;;       to this state)        | /
+;;                             |/
+;;                             o
+;;
+;; But if you're unlucky, and you happen to have moved the point (say) after
+;; getting to the state labelled "got this far", then you've "broken the undo
+;; chain". Hold on to something solid, because things are about to get
+;; hairy. If you try to undo now, Emacs thinks you're trying to undo the
+;; undos! So to get back to the initial state you now have to rewind through
+;; *all* the changes, including the undos you just did:
+;;
+;;      (trying to get   o                          x  (finally got there!)
+;;       to this state)  |                          |
+;;                       |                          |
+;;                       o  o     o     o     o     o
+;;                       |  |\    |\    |\    |\    |
+;;                       |  | \   | \   | \   | \   |
+;;                       o  o  |  |  o  o  o  |  o  o
+;;                       | /   |  |  | /   |  |  | /
+;;                       |/    |  |  |/    |  |  |/
+;;      (already undid   o     |  |  o<.   |  |  o
+;;       to this state)        | /     :   | /
+;;                             |/      :   |/
+;;                             o       :   o
+;;                                     :
+;;                             (got this far, but
+;;                              broke the undo chain)
+;;
+;; Confused?
+;;
+;; In practice you can just hold down the undo key until you reach the buffer
+;; state that you want. But whatever you do, don't move around in the buffer
+;; to *check* that you've got back to where you want! Because you'll break the
+;; undo chain, and then you'll have to traverse the entire string of undos
+;; again, just to get back to the point at which you broke the
+;; chain. Undo-in-region and commands such as `undo-only' help to make using
+;; Emacs' undo a little easier, but nonetheless it remains confusing for many
+;; people.
+;;
+;;
+;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent
+;; the history we've been discussing (make a few edits, undo a couple of them,
+;; and edit again)? The diagram that conceptually represented our undo
+;; history, before we started discussing specific undo systems? It looked like
+;; this:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o
+;;                                |\
+;;                                | \
+;;                                o  x  (current state)
+;;                                |
+;;                                |
+;;                                o
+;;
+;; Well, that's *exactly* what the undo history looks like to
+;; `undo-tree-mode'.  It doesn't discard the old branch (as standard undo/redo
+;; does), nor does it treat undos as new changes to be added to the end of a
+;; linear string of buffer states (as Emacs' undo does). It just keeps track
+;; of the tree of branching changes that make up the entire undo history.
+;;
+;; If you undo from this point, you'll rewind back up the tree to the previous
+;; state:
+;;
+;;                                o
+;;                                |
+;;                                |
+;;                                x  (undo)
+;;                                |\
+;;                                | \
+;;                                o  o
+;;                                |
+;;                                |
+;;                                o
+;;
+;; If you were to undo again, you'd rewind back to the initial state. If on
+;; the other hand you redo the change, you'll end up back at the bottom of the
+;; most recent branch:
+;;
+;;                                o  (undo takes you here)
+;;                                |
+;;                                |
+;;                                o  (start here)
+;;                                |\
+;;                                | \
+;;                                o  x  (redo takes you here)
+;;                                |
+;;                                |
+;;                                o
+;;
+;; So far, this is just like the standard undo/redo system. But what if you
+;; want to return to a buffer state located on a previous branch of the
+;; history? Since `undo-tree-mode' keeps the entire history, you simply need
+;; to tell it to switch to a different branch, and then redo the changes you
+;; want:
+;;
+;;                                o
+;;                                |
+;;                                |
+;;                                o  (start here, but switch
+;;                                |\  to the other branch)
+;;                                | \
+;;                        (redo)  o  o
+;;                                |
+;;                                |
+;;                        (redo)  x
+;;
+;; Now you're on the other branch, if you undo and redo changes you'll stay on
+;; that branch, moving up and down through the buffer states located on that
+;; branch. Until you decide to switch branches again, of course.
+;;
+;; Real undo trees might have multiple branches and sub-branches:
+;;
+;;                                o
+;;                            ____|______
+;;                           /           \
+;;                          o             o
+;;                      ____|__         __|
+;;                     /    |  \       /   \
+;;                    o     o   o     o     x
+;;                    |               |
+;;                   / \             / \
+;;                  o   o           o   o
+;;
+;; Trying to imagine what Emacs' undo would do as you move about such a tree
+;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're
+;; just moving around this undo history tree. Most of the time, you'll
+;; probably only need to stay on the most recent branch, in which case it
+;; behaves like standard undo/redo, and is just as simple to understand. But
+;; if you ever need to recover a buffer state on a different branch, the
+;; possibility of switching between branches and accessing the full undo
+;; history is still there.
+;;
+;;
+;;
+;; The Undo-Tree Visualizer
+;; ========================
+;;
+;; Actually, it gets better. You don't have to imagine all these tree
+;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which
+;; draws them for you! In fact, it draws even better diagrams: it highlights
+;; the node representing the current buffer state, it highlights the current
+;; branch, and you can toggle the display of time-stamps (by hitting "t") and
+;; a diff of the undo changes (by hitting "d"). (There's one other tiny
+;; difference: the visualizer puts the most recent branch on the left rather
+;; than the right.)
+;;
+;; Bring up the undo tree visualizer whenever you want by hitting "C-x u".
+;;
+;; In the visualizer, the usual keys for moving up and down a buffer instead
+;; move up and down the undo history tree (e.g. the up and down arrow keys, or
+;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo
+;; history you are visualizing) is updated as you move around the undo tree in
+;; the visualizer. If you reach a branch point in the visualizer, the usual
+;; keys for moving forward and backward in a buffer instead switch branch
+;; (e.g. the left and right arrow keys, or "C-f" and "C-b").
+;;
+;; Clicking with the mouse on any node in the visualizer will take you
+;; directly to that node, resetting the state of the parent buffer to the
+;; state represented by that node.
+;;
+;; You can also select nodes directly using the keyboard, by hitting "s" to
+;; toggle selection mode. The usual motion keys now allow you to move around
+;; the tree without changing the parent buffer. Hitting <enter> will reset the
+;; state of the parent buffer to the state represented by the currently
+;; selected node.
+;;
+;; It can be useful to see how long ago the parent buffer was in the state
+;; represented by a particular node in the visualizer. Hitting "t" in the
+;; visualizer toggles the display of time-stamps for all the nodes. (Note
+;; that, because of the way `undo-tree-mode' works, these time-stamps may be
+;; somewhat later than the true times, especially if it's been a long time
+;; since you last undid any changes.)
+;;
+;; To get some idea of what changes are represented by a given node in the
+;; tree, it can be useful to see a diff of the changes. Hit "d" in the
+;; visualizer to toggle a diff display. This normally displays a diff between
+;; the current state and the previous one, i.e. it shows you the changes that
+;; will be applied if you undo (move up the tree). However, the diff display
+;; really comes into its own in the visualizer's selection mode (see above),
+;; where it instead shows a diff between the current state and the currently
+;; selected state, i.e. it shows you the changes that will be applied if you
+;; reset to the selected state.
+;;
+;; (Note that the diff is generated by the Emacs `diff' command, and is
+;; displayed using `diff-mode'. See the corresponding customization groups if
+;; you want to customize the diff display.)
+;;
+;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in
+;; whatever state you ended at. Hitting "C-q" will abort the visualizer,
+;; returning the parent buffer to whatever state it was originally in when the
+;; visualizer was .
+;;
+;;
+;;
+;; Undo-in-Region
+;; ==============
+;;
+;; Emacs allows a very useful and powerful method of undoing only selected
+;; changes: when a region is active, only changes that affect the text within
+;; that region will be undone. With the standard Emacs undo system, changes
+;; produced by undoing-in-region naturally get added onto the end of the
+;; linear undo history:
+;;
+;;                       o
+;;                       |
+;;                       |  x  (second undo-in-region)
+;;                       o  |
+;;                       |  |
+;;                       |  o  (first undo-in-region)
+;;                       o  |
+;;                       | /
+;;                       |/
+;;                       o
+;;
+;; You can of course redo these undos-in-region as usual, by undoing the
+;; undos:
+;;
+;;                       o
+;;                       |
+;;                       |  o_
+;;                       o  | \
+;;                       |  |  |
+;;                       |  o  o  (undo the undo-in-region)
+;;                       o  |  |
+;;                       | /   |
+;;                       |/    |
+;;                       o     x  (undo the undo-in-region)
+;;
+;;
+;; In `undo-tree-mode', undo-in-region works similarly: when there's an active
+;; region, undoing only undoes changes that affect that region. However, the
+;; way these undos-in-region are recorded in the undo history is quite
+;; different. In `undo-tree-mode', undo-in-region creates a new branch in the
+;; undo history. The new branch consists of an undo step that undoes some of
+;; the changes that affect the current region, and another step that undoes
+;; the remaining changes needed to rejoin the previous undo history.
+;;
+;;      Previous undo history                Undo-in-region
+;;
+;;               o                                o
+;;               |                                |
+;;               |                                |
+;;               o                                o
+;;               |                                |\
+;;               |                                | \
+;;               o                                o  x  (undo-in-region)
+;;               |                                |  |
+;;               |                                |  |
+;;               x                                o  o
+;;
+;; As long as you don't change the active region after undoing-in-region,
+;; continuing to undo-in-region extends the new branch, pulling more changes
+;; that affect the current region into an undo step immediately above your
+;; current location in the undo tree, and pushing the point at which the new
+;; branch is attached further up the tree:
+;;
+;;      First undo-in-region                 Second undo-in-region
+;;
+;;               o                                o
+;;               |                                |\
+;;               |                                | \
+;;               o                                o  x  (undo-in-region)
+;;               |\                               |  |
+;;               | \                              |  |
+;;               o  x                             o  o
+;;               |  |                             |  |
+;;               |  |                             |  |
+;;               o  o                             o  o
+;;
+;; Redoing takes you back down the undo tree, as usual (as long as you haven't
+;; changed the active region after undoing-in-region, it doesn't matter if it
+;; is still active):
+;;
+;;                       o
+;;                      |\
+;;                      | \
+;;                      o  o
+;;                      |  |
+;;                      |  |
+;;                      o  o  (redo)
+;;                      |  |
+;;                      |  |
+;;                      o  x  (redo)
+;;
+;;
+;; What about redo-in-region? Obviously, this only makes sense if you have
+;; already undone some changes, so that there are some changes to redo!
+;; Redoing-in-region splits off a new branch of the undo history below your
+;; current location in the undo tree. This time, the new branch consists of a
+;; redo step that redoes some of the redo changes that affect the current
+;; region, followed by all the remaining redo changes.
+;;
+;;      Previous undo history                Redo-in-region
+;;
+;;               o                                o
+;;               |                                |
+;;               |                                |
+;;               x                                o
+;;               |                                |\
+;;               |                                | \
+;;               o                                o  x  (redo-in-region)
+;;               |                                |  |
+;;               |                                |  |
+;;               o                                o  o
+;;
+;; As long as you don't change the active region after redoing-in-region,
+;; continuing to redo-in-region extends the new branch, pulling more redo
+;; changes into a redo step immediately below your current location in the
+;; undo tree.
+;;
+;;      First redo-in-region                 Second redo-in-region
+;;
+;;          o                                     o
+;;          |                                     |
+;;          |                                     |
+;;          o                                     o
+;;          |\                                    |\
+;;          | \                                   | \
+;;          o  x  (redo-in-region)                o  o
+;;          |  |                                  |  |
+;;          |  |                                  |  |
+;;          o  o                                  o  x  (redo-in-region)
+;;                                                   |
+;;                                                   |
+;;                                                   o
+;;
+;; Note that undo-in-region and redo-in-region only ever add new changes to
+;; the undo tree, they *never* modify existing undo history. So you can always
+;; return to previous buffer states by switching to a previous branch of the
+;; tree.
+
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'diff)
+
+
+\f
+;;; =====================================================================
+;;;              Compatibility hacks for older Emacsen
+
+;; `characterp' isn't defined in Emacs versions < 23
+(unless (fboundp 'characterp)
+  (defalias 'characterp 'char-valid-p))
+
+;; `region-active-p' isn't defined in Emacs versions < 23
+(unless (fboundp 'region-active-p)
+  (defun region-active-p () (and transient-mark-mode mark-active)))
+
+
+;; `registerv' defstruct isn't defined in Emacs versions < 24
+(unless (fboundp 'registerv-make)
+  (defmacro registerv-make (data &rest _dummy) data))
+
+(unless (fboundp 'registerv-data)
+  (defmacro registerv-data (data) data))
+
+
+;; `diff-no-select' and `diff-file-local-copy' aren't defined in Emacs
+;; versions < 24 (copied and adapted from Emacs 24)
+(unless (fboundp 'diff-no-select)
+  (defun diff-no-select (old new &optional switches no-async buf)
+    ;; Noninteractive helper for creating and reverting diff buffers
+    (unless (bufferp new) (setq new (expand-file-name new)))
+    (unless (bufferp old) (setq old (expand-file-name old)))
+    (or switches (setq switches diff-switches)) ; If not specified, use default.
+    (unless (listp switches) (setq switches (list switches)))
+    (or buf (setq buf (get-buffer-create "*Diff*")))
+    (let* ((old-alt (diff-file-local-copy old))
+          (new-alt (diff-file-local-copy new))
+          (command
+           (mapconcat 'identity
+                      `(,diff-command
+                        ;; Use explicitly specified switches
+                        ,@switches
+                        ,@(mapcar #'shell-quote-argument
+                                  (nconc
+                                   (when (or old-alt new-alt)
+                                     (list "-L" (if (stringp old)
+                                                    old (prin1-to-string old))
+                                           "-L" (if (stringp new)
+                                                    new (prin1-to-string new))))
+                                   (list (or old-alt old)
+                                         (or new-alt new)))))
+                      " "))
+          (thisdir default-directory))
+      (with-current-buffer buf
+       (setq buffer-read-only t)
+       (buffer-disable-undo (current-buffer))
+       (let ((inhibit-read-only t))
+         (erase-buffer))
+       (buffer-enable-undo (current-buffer))
+       (diff-mode)
+       (set (make-local-variable 'revert-buffer-function)
+            (lambda (_ignore-auto _noconfirm)
+              (diff-no-select old new switches no-async (current-buffer))))
+       (setq default-directory thisdir)
+       (let ((inhibit-read-only t))
+         (insert command "\n"))
+       (if (and (not no-async) (fboundp 'start-process))
+           (let ((proc (start-process "Diff" buf shell-file-name
+                                      shell-command-switch command)))
+             (set-process-filter proc 'diff-process-filter)
+             (set-process-sentinel
+              proc (lambda (proc _msg)
+                     (with-current-buffer (process-buffer proc)
+                       (diff-sentinel (process-exit-status proc))
+                       (if old-alt (delete-file old-alt))
+                       (if new-alt (delete-file new-alt))))))
+         ;; Async processes aren't available.
+         (let ((inhibit-read-only t))
+           (diff-sentinel
+            (call-process shell-file-name nil buf nil
+                          shell-command-switch command))
+           (if old-alt (delete-file old-alt))
+           (if new-alt (delete-file new-alt)))))
+      buf)))
+
+(unless (fboundp 'diff-file-local-copy)
+  (defun diff-file-local-copy (file-or-buf)
+    (if (bufferp file-or-buf)
+       (with-current-buffer file-or-buf
+         (let ((tempfile (make-temp-file "buffer-content-")))
+           (write-region nil nil tempfile nil 'nomessage)
+           tempfile))
+      (file-local-copy file-or-buf))))
+
+
+;; `user-error' isn't defined in Emacs < 24.3
+(unless (fboundp 'user-error)
+  (defalias 'user-error 'error)
+  ;; prevent debugger being called on user errors
+  (add-to-list 'debug-ignored-errors "^No further undo information")
+  (add-to-list 'debug-ignored-errors "^No further redo information")
+  (add-to-list 'debug-ignored-errors "^No further redo information for region"))
+
+
+
+
+\f
+;;; =====================================================================
+;;;              Global variables and customization options
+
+(defvar buffer-undo-tree nil
+  "Tree of undo entries in current buffer.")
+(make-variable-buffer-local 'buffer-undo-tree)
+(put 'buffer-undo-tree 'permanent-local t)
+
+
+(defgroup undo-tree nil
+  "Tree undo/redo."
+  :group 'undo)
+
+(defcustom undo-tree-mode-lighter " Undo-Tree"
+  "Lighter displayed in mode line
+when `undo-tree-mode' is enabled."
+  :group 'undo-tree
+  :type 'string)
+
+
+(defcustom undo-tree-incompatible-major-modes '(term-mode)
+  "List of major-modes in which `undo-tree-mode' should not be enabled.
+\(See `turn-on-undo-tree-mode'.\)"
+  :group 'undo-tree
+  :type '(repeat symbol))
+
+
+(defcustom undo-tree-enable-undo-in-region t
+  "When non-nil, enable undo-in-region.
+
+When undo-in-region is enabled, undoing or redoing when the
+region is active (in `transient-mark-mode') or with a prefix
+argument (not in `transient-mark-mode') only undoes changes
+within the current region."
+  :group 'undo-tree
+  :type 'boolean)
+
+
+(defcustom undo-tree-auto-save-history nil
+  "When non-nil, `undo-tree-mode' will save undo history to file
+when a buffer is saved to file.
+
+It will automatically load undo history when a buffer is loaded
+from file, if an undo save file exists.
+
+Undo-tree history is saved to a file called
+\".<buffer-file-name>.~undo-tree\" in the same directory as the
+file itself.
+
+WARNING! `undo-tree-auto-save-history' will not work properly in
+Emacs versions prior to 24.3, so it cannot be enabled via
+the customization interface in versions earlier than that one. To
+ignore this warning and enable it regardless, set
+`undo-tree-auto-save-history' to a non-nil value outside of
+customize."
+  :group 'undo-tree
+  :type (if (version-list-< (version-to-list emacs-version) '(24 3))
+           '(choice (const :tag "<disabled>" nil))
+         'boolean))
+
+
+(defcustom undo-tree-history-directory-alist nil
+  "Alist of filename patterns and undo history directory names.
+Each element looks like (REGEXP . DIRECTORY).  Undo history for
+files with names matching REGEXP will be saved in DIRECTORY.
+DIRECTORY may be relative or absolute.  If it is absolute, so
+that all matching files are backed up into the same directory,
+the file names in this directory will be the full name of the
+file backed up with all directory separators changed to `!' to
+prevent clashes.  This will not work correctly if your filesystem
+truncates the resulting name.
+
+For the common case of all backups going into one directory, the
+alist should contain a single element pairing \".\" with the
+appropriate directory name.
+
+If this variable is nil, or it fails to match a filename, the
+backup is made in the original file's directory.
+
+On MS-DOS filesystems without long names this variable is always
+ignored."
+  :group 'undo-tree
+  :type '(repeat (cons (regexp :tag "Regexp matching filename")
+                      (directory :tag "Undo history directory name"))))
+
+
+
+(defcustom undo-tree-visualizer-relative-timestamps t
+  "When non-nil, display times relative to current time
+when displaying time stamps in visualizer.
+
+Otherwise, display absolute times."
+  :group 'undo-tree
+  :type 'boolean)
+
+
+(defcustom undo-tree-visualizer-timestamps nil
+  "When non-nil, display time-stamps by default
+in undo-tree visualizer.
+
+\\<undo-tree-visualizer-map>You can always toggle time-stamps on and off \
+using \\[undo-tree-visualizer-toggle-timestamps], regardless of the
+setting of this variable."
+  :group 'undo-tree
+  :type 'boolean)
+
+
+(defcustom undo-tree-visualizer-diff nil
+  "When non-nil, display diff by default in undo-tree visualizer.
+
+\\<undo-tree-visualizer-map>You can always toggle the diff display \
+using \\[undo-tree-visualizer-toggle-diff], regardless of the
+setting of this variable."
+  :group 'undo-tree
+  :type 'boolean)
+
+
+(defcustom undo-tree-visualizer-lazy-drawing 100
+  "When non-nil, use lazy undo-tree drawing in visualizer.
+
+Setting this to a number causes the visualizer to switch to lazy
+drawing when the number of nodes in the tree is larger than this
+value.
+
+Lazy drawing means that only the visible portion of the tree will
+be drawn initially , and the tree will be extended later as
+needed. For the most part, the only visible effect of this is to
+significantly speed up displaying the visualizer for very large
+trees.
+
+There is one potential negative effect of lazy drawing. Other
+branches of the tree will only be drawn once the node from which
+they branch off becomes visible. So it can happen that certain
+portions of the tree that would be shown with lazy drawing
+disabled, will not be drawn immediately when it is
+enabled. However, this effect is quite rare in practice."
+  :group 'undo-tree
+  :type '(choice (const :tag "never" nil)
+                (const :tag "always" t)
+                (integer :tag "> size")))
+
+
+(defface undo-tree-visualizer-default-face
+  '((((class color)) :foreground "gray"))
+  "Face used to draw undo-tree in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-current-face
+  '((((class color)) :foreground "red"))
+  "Face used to highlight current undo-tree node in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-active-branch-face
+  '((((class color) (background dark))
+     (:foreground "white" :weight bold))
+    (((class color) (background light))
+     (:foreground "black" :weight bold)))
+  "Face used to highlight active undo-tree branch in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-register-face
+  '((((class color)) :foreground "yellow"))
+  "Face used to highlight undo-tree nodes saved to a register
+in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-unmodified-face
+  '((((class color)) :foreground "cyan"))
+  "Face used to highlight nodes corresponding to unmodified buffers
+in visualizer."
+  :group 'undo-tree)
+
+
+(defvar undo-tree-visualizer-parent-buffer nil
+  "Parent buffer in visualizer.")
+(make-variable-buffer-local 'undo-tree-visualizer-parent-buffer)
+
+;; stores modification time of parent buffer's file, if any
+(defvar undo-tree-visualizer-parent-mtime nil)
+(make-variable-buffer-local 'undo-tree-visualizer-parent-mtime)
+
+;; stores current horizontal spacing needed for drawing undo-tree
+(defvar undo-tree-visualizer-spacing nil)
+(make-variable-buffer-local 'undo-tree-visualizer-spacing)
+
+;; calculate horizontal spacing required for drawing tree with current
+;; settings
+(defsubst undo-tree-visualizer-calculate-spacing ()
+  (if undo-tree-visualizer-timestamps
+      (if undo-tree-visualizer-relative-timestamps 9 13)
+    3))
+
+;; holds node that was current when visualizer was invoked
+(defvar undo-tree-visualizer-initial-node nil)
+(make-variable-buffer-local 'undo-tree-visualizer-initial-node)
+
+;; holds currently selected node in visualizer selection mode
+(defvar undo-tree-visualizer-selected-node nil)
+(make-variable-buffer-local 'undo-tree-visualizer-selected)
+
+;; used to store nodes at edge of currently drawn portion of tree
+(defvar undo-tree-visualizer-needs-extending-down nil)
+(make-variable-buffer-local 'undo-tree-visualizer-needs-extending-down)
+(defvar undo-tree-visualizer-needs-extending-up nil)
+(make-variable-buffer-local 'undo-tree-visualizer-needs-extending-up)
+
+;; dynamically bound to t when undoing from visualizer, to inhibit
+;; `undo-tree-kill-visualizer' hook function in parent buffer
+(defvar undo-tree-inhibit-kill-visualizer nil)
+
+;; can be let-bound to a face name, used in drawing functions
+(defvar undo-tree-insert-face nil)
+
+;; visualizer buffer names
+(defconst undo-tree-visualizer-buffer-name " *undo-tree*")
+(defconst undo-tree-diff-buffer-name "*undo-tree Diff*")
+
+;; install history-auto-save hooks
+(add-hook 'write-file-functions 'undo-tree-save-history-hook)
+(add-hook 'find-file-hook 'undo-tree-load-history-hook)
+
+
+
+\f
+;;; =================================================================
+;;;                          Default keymaps
+
+(defvar undo-tree-map nil
+  "Keymap used in undo-tree-mode.")
+
+(unless undo-tree-map
+  (let ((map (make-sparse-keymap)))
+    ;; remap `undo' and `undo-only' to `undo-tree-undo'
+    (define-key map [remap undo] 'undo-tree-undo)
+    (define-key map [remap undo-only] 'undo-tree-undo)
+    ;; bind standard undo bindings (since these match redo counterparts)
+    (define-key map (kbd "C-/") 'undo-tree-undo)
+    (define-key map "\C-_" 'undo-tree-undo)
+    ;; redo doesn't exist normally, so define our own keybindings
+    (define-key map (kbd "C-?") 'undo-tree-redo)
+    (define-key map (kbd "M-_") 'undo-tree-redo)
+    ;; just in case something has defined `redo'...
+    (define-key map [remap redo] 'undo-tree-redo)
+    ;; we use "C-x u" for the undo-tree visualizer
+    (define-key map (kbd "\C-x u") 'undo-tree-visualize)
+    ;; bind register commands
+    (define-key map (kbd "C-x r u") 'undo-tree-save-state-to-register)
+    (define-key map (kbd "C-x r U") 'undo-tree-restore-state-from-register)
+    ;; set keymap
+    (setq undo-tree-map map)))
+
+
+(defvar undo-tree-visualizer-map nil
+  "Keymap used in undo-tree visualizer.")
+
+(unless undo-tree-visualizer-map
+  (let ((map (make-sparse-keymap)))
+    ;; vertical motion keys undo/redo
+    (define-key map [remap previous-line] 'undo-tree-visualize-undo)
+    (define-key map [remap next-line] 'undo-tree-visualize-redo)
+    (define-key map [up] 'undo-tree-visualize-undo)
+    (define-key map "p" 'undo-tree-visualize-undo)
+    (define-key map "\C-p" 'undo-tree-visualize-undo)
+    (define-key map [down] 'undo-tree-visualize-redo)
+    (define-key map "n" 'undo-tree-visualize-redo)
+    (define-key map "\C-n" 'undo-tree-visualize-redo)
+    ;; horizontal motion keys switch branch
+    (define-key map [remap forward-char]
+      'undo-tree-visualize-switch-branch-right)
+    (define-key map [remap backward-char]
+      'undo-tree-visualize-switch-branch-left)
+    (define-key map [right] 'undo-tree-visualize-switch-branch-right)
+    (define-key map "f" 'undo-tree-visualize-switch-branch-right)
+    (define-key map "\C-f" 'undo-tree-visualize-switch-branch-right)
+    (define-key map [left] 'undo-tree-visualize-switch-branch-left)
+    (define-key map "b" 'undo-tree-visualize-switch-branch-left)
+    (define-key map "\C-b" 'undo-tree-visualize-switch-branch-left)
+    ;; paragraph motion keys undo/redo to significant points in tree
+    (define-key map [remap backward-paragraph] 'undo-tree-visualize-undo-to-x)
+    (define-key map [remap forward-paragraph] 'undo-tree-visualize-redo-to-x)
+    (define-key map "\M-{" 'undo-tree-visualize-undo-to-x)
+    (define-key map "\M-}" 'undo-tree-visualize-redo-to-x)
+    (define-key map [C-down] 'undo-tree-visualize-undo-to-x)
+    (define-key map [C-up] 'undo-tree-visualize-redo-to-x)
+    ;; mouse sets buffer state to node at click
+    (define-key map [mouse-1] 'undo-tree-visualizer-mouse-set)
+    ;; toggle timestamps
+    (define-key map "t" 'undo-tree-visualizer-toggle-timestamps)
+    ;; toggle diff
+    (define-key map "d" 'undo-tree-visualizer-toggle-diff)
+    ;; selection mode
+    (define-key map "s" 'undo-tree-visualizer-selection-mode)
+    ;; horizontal scrolling may be needed if the tree is very wide
+    (define-key map "," 'undo-tree-visualizer-scroll-left)
+    (define-key map "." 'undo-tree-visualizer-scroll-right)
+    (define-key map "<" 'undo-tree-visualizer-scroll-left)
+    (define-key map ">" 'undo-tree-visualizer-scroll-right)
+    ;; vertical scrolling may be needed if the tree is very tall
+    (define-key map [next] 'undo-tree-visualizer-scroll-up)
+    (define-key map [prior] 'undo-tree-visualizer-scroll-down)
+    ;; quit/abort visualizer
+    (define-key map "q" 'undo-tree-visualizer-quit)
+    (define-key map "\C-q" 'undo-tree-visualizer-abort)
+    ;; set keymap
+    (setq undo-tree-visualizer-map map)))
+
+
+(defvar undo-tree-visualizer-selection-map nil
+  "Keymap used in undo-tree visualizer selection mode.")
+
+(unless undo-tree-visualizer-selection-map
+  (let ((map (make-sparse-keymap)))
+    ;; vertical motion keys move up and down tree
+    (define-key map [remap previous-line]
+      'undo-tree-visualizer-select-previous)
+    (define-key map [remap next-line]
+      'undo-tree-visualizer-select-next)
+    (define-key map [up] 'undo-tree-visualizer-select-previous)
+    (define-key map "p" 'undo-tree-visualizer-select-previous)
+    (define-key map "\C-p" 'undo-tree-visualizer-select-previous)
+    (define-key map [down] 'undo-tree-visualizer-select-next)
+    (define-key map "n" 'undo-tree-visualizer-select-next)
+    (define-key map "\C-n" 'undo-tree-visualizer-select-next)
+    ;; vertical scroll keys move up and down quickly
+    (define-key map [next]
+      (lambda () (interactive) (undo-tree-visualizer-select-next 10)))
+    (define-key map [prior]
+      (lambda () (interactive) (undo-tree-visualizer-select-previous 10)))
+    ;; horizontal motion keys move to left and right siblings
+    (define-key map [remap forward-char] 'undo-tree-visualizer-select-right)
+    (define-key map [remap backward-char] 'undo-tree-visualizer-select-left)
+    (define-key map [right] 'undo-tree-visualizer-select-right)
+    (define-key map "f" 'undo-tree-visualizer-select-right)
+    (define-key map "\C-f" 'undo-tree-visualizer-select-right)
+    (define-key map [left] 'undo-tree-visualizer-select-left)
+    (define-key map "b" 'undo-tree-visualizer-select-left)
+    (define-key map "\C-b" 'undo-tree-visualizer-select-left)
+    ;; horizontal scroll keys move left or right quickly
+    (define-key map ","
+      (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
+    (define-key map "."
+      (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
+    (define-key map "<"
+      (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
+    (define-key map ">"
+      (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
+    ;; mouse or <enter> sets buffer state to node at point/click
+    (define-key map "\r" 'undo-tree-visualizer-set)
+    (define-key map [mouse-1] 'undo-tree-visualizer-mouse-set)
+    ;; toggle timestamps
+    (define-key map "t" 'undo-tree-visualizer-toggle-timestamps)
+    ;; toggle diff
+    (define-key map "d" 'undo-tree-visualizer-selection-toggle-diff)
+    ;; quit visualizer selection mode
+    (define-key map "s" 'undo-tree-visualizer-mode)
+    ;; quit visualizer
+    (define-key map "q" 'undo-tree-visualizer-quit)
+    (define-key map "\C-q" 'undo-tree-visualizer-abort)
+    ;; set keymap
+    (setq undo-tree-visualizer-selection-map map)))
+
+
+
+\f
+;;; =====================================================================
+;;;                     Undo-tree data structure
+
+(defstruct
+  (undo-tree
+   :named
+   (:constructor nil)
+   (:constructor make-undo-tree
+                 (&aux
+                  (root (undo-tree-make-node nil nil))
+                  (current root)
+                  (size 0)
+                 (count 0)
+                 (object-pool (make-hash-table :test 'eq :weakness 'value))))
+   ;;(:copier nil)
+   )
+  root current size count object-pool)
+
+
+
+(defstruct
+  (undo-tree-node
+   (:type vector)   ; create unnamed struct
+   (:constructor nil)
+   (:constructor undo-tree-make-node
+                 (previous undo
+                 &optional redo
+                  &aux
+                  (timestamp (current-time))
+                  (branch 0)))
+   (:constructor undo-tree-make-node-backwards
+                 (next-node undo
+                 &optional redo
+                  &aux
+                  (next (list next-node))
+                  (timestamp (current-time))
+                  (branch 0)))
+   (:copier nil))
+  previous next undo redo timestamp branch meta-data)
+
+
+(defmacro undo-tree-node-p (n)
+  (let ((len (length (undo-tree-make-node nil nil))))
+    `(and (vectorp ,n) (= (length ,n) ,len))))
+
+
+
+(defstruct
+  (undo-tree-region-data
+   (:type vector)   ; create unnamed struct
+   (:constructor nil)
+   (:constructor undo-tree-make-region-data
+                (&optional undo-beginning undo-end
+                            redo-beginning redo-end))
+   (:constructor undo-tree-make-undo-region-data
+                (undo-beginning undo-end))
+   (:constructor undo-tree-make-redo-region-data
+                (redo-beginning redo-end))
+   (:copier nil))
+  undo-beginning undo-end redo-beginning redo-end)
+
+
+(defmacro undo-tree-region-data-p (r)
+  (let ((len (length (undo-tree-make-region-data))))
+    `(and (vectorp ,r) (= (length ,r) ,len))))
+
+(defmacro undo-tree-node-clear-region-data (node)
+  `(setf (undo-tree-node-meta-data ,node)
+        (delq nil
+              (delq :region
+                    (plist-put (undo-tree-node-meta-data ,node)
+                               :region nil)))))
+
+
+(defmacro undo-tree-node-undo-beginning (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-undo-beginning r))))
+
+(defmacro undo-tree-node-undo-end (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-undo-end r))))
+
+(defmacro undo-tree-node-redo-beginning (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-redo-beginning r))))
+
+(defmacro undo-tree-node-redo-end (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-redo-end r))))
+
+
+(defsetf undo-tree-node-undo-beginning (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :region
+                       (setq r (undo-tree-make-region-data)))))
+     (setf (undo-tree-region-data-undo-beginning r) ,val)))
+
+(defsetf undo-tree-node-undo-end (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :region
+                       (setq r (undo-tree-make-region-data)))))
+     (setf (undo-tree-region-data-undo-end r) ,val)))
+
+(defsetf undo-tree-node-redo-beginning (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :region
+                       (setq r (undo-tree-make-region-data)))))
+     (setf (undo-tree-region-data-redo-beginning r) ,val)))
+
+(defsetf undo-tree-node-redo-end (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :region
+                       (setq r (undo-tree-make-region-data)))))
+     (setf (undo-tree-region-data-redo-end r) ,val)))
+
+
+
+(defstruct
+  (undo-tree-visualizer-data
+   (:type vector)   ; create unnamed struct
+   (:constructor nil)
+   (:constructor undo-tree-make-visualizer-data
+                (&optional lwidth cwidth rwidth marker))
+   (:copier nil))
+  lwidth cwidth rwidth marker)
+
+
+(defmacro undo-tree-visualizer-data-p (v)
+  (let ((len (length (undo-tree-make-visualizer-data))))
+    `(and (vectorp ,v) (= (length ,v) ,len))))
+
+(defun undo-tree-node-clear-visualizer-data (node)
+  (let ((plist (undo-tree-node-meta-data node)))
+    (if (eq (car plist) :visualizer)
+       (setf (undo-tree-node-meta-data node) (nthcdr 2 plist))
+      (while (and plist (not (eq (cadr plist) :visualizer)))
+       (setq plist (cdr plist)))
+      (if plist (setcdr plist (nthcdr 3 plist))))))
+
+(defmacro undo-tree-node-lwidth (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-lwidth v))))
+
+(defmacro undo-tree-node-cwidth (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-cwidth v))))
+
+(defmacro undo-tree-node-rwidth (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-rwidth v))))
+
+(defmacro undo-tree-node-marker (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-marker v))))
+
+
+(defsetf undo-tree-node-lwidth (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :visualizer
+                       (setq v (undo-tree-make-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-lwidth v) ,val)))
+
+(defsetf undo-tree-node-cwidth (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :visualizer
+                       (setq v (undo-tree-make-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-cwidth v) ,val)))
+
+(defsetf undo-tree-node-rwidth (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :visualizer
+                       (setq v (undo-tree-make-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-rwidth v) ,val)))
+
+(defsetf undo-tree-node-marker (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+            (plist-put (undo-tree-node-meta-data ,node) :visualizer
+                       (setq v (undo-tree-make-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-marker v) ,val)))
+
+
+
+(defstruct
+  (undo-tree-register-data
+   (:type vector)
+   (:constructor nil)
+   (:constructor undo-tree-make-register-data (buffer node)))
+  buffer node)
+
+(defun undo-tree-register-data-p (data)
+  (and (vectorp data)
+       (= (length data) 2)
+       (undo-tree-node-p (undo-tree-register-data-node data))))
+
+(defun undo-tree-register-data-print-func (data)
+  (princ (format "an undo-tree state for buffer %s"
+                (undo-tree-register-data-buffer data))))
+
+(defmacro undo-tree-node-register (node)
+  `(plist-get (undo-tree-node-meta-data ,node) :register))
+
+(defsetf undo-tree-node-register (node) (val)
+  `(setf (undo-tree-node-meta-data ,node)
+        (plist-put (undo-tree-node-meta-data ,node) :register ,val)))
+
+
+
+\f
+;;; =====================================================================
+;;;              Basic undo-tree data structure functions
+
+(defun undo-tree-grow (undo)
+  "Add an UNDO node to current branch of `buffer-undo-tree'."
+  (let* ((current (undo-tree-current buffer-undo-tree))
+         (new (undo-tree-make-node current undo)))
+    (push new (undo-tree-node-next current))
+    (setf (undo-tree-current buffer-undo-tree) new)))
+
+
+(defun undo-tree-grow-backwards (node undo &optional redo)
+  "Add new node *above* undo-tree NODE, and return new node.
+Note that this will overwrite NODE's \"previous\" link, so should
+only be used on a detached NODE, never on nodes that are already
+part of `buffer-undo-tree'."
+  (let ((new (undo-tree-make-node-backwards node undo redo)))
+    (setf (undo-tree-node-previous node) new)
+    new))
+
+
+(defun undo-tree-splice-node (node splice)
+  "Splice NODE into undo tree, below node SPLICE.
+Note that this will overwrite NODE's \"next\" and \"previous\"
+links, so should only be used on a detached NODE, never on nodes
+that are already part of `buffer-undo-tree'."
+  (setf (undo-tree-node-next node) (undo-tree-node-next splice)
+       (undo-tree-node-branch node) (undo-tree-node-branch splice)
+       (undo-tree-node-previous node) splice
+       (undo-tree-node-next splice) (list node)
+       (undo-tree-node-branch splice) 0)
+  (dolist (n (undo-tree-node-next node))
+    (setf (undo-tree-node-previous n) node)))
+
+
+(defun undo-tree-snip-node (node)
+  "Snip NODE out of undo tree."
+  (let* ((parent (undo-tree-node-previous node))
+        position p)
+    ;; if NODE is only child, replace parent's next links with NODE's
+    (if (= (length (undo-tree-node-next parent)) 0)
+       (setf (undo-tree-node-next parent) (undo-tree-node-next node)
+             (undo-tree-node-branch parent) (undo-tree-node-branch node))
+      ;; otherwise...
+      (setq position (undo-tree-position node (undo-tree-node-next parent)))
+      (cond
+       ;; if active branch used do go via NODE, set parent's branch to active
+       ;; branch of NODE
+       ((= (undo-tree-node-branch parent) position)
+       (setf (undo-tree-node-branch parent)
+             (+ position (undo-tree-node-branch node))))
+       ;; if active branch didn't go via NODE, update parent's branch to point
+       ;; to same node as before
+       ((> (undo-tree-node-branch parent) position)
+       (incf (undo-tree-node-branch parent)
+             (1- (length (undo-tree-node-next node))))))
+      ;; replace NODE in parent's next list with NODE's entire next list
+      (if (= position 0)
+         (setf (undo-tree-node-next parent)
+               (nconc (undo-tree-node-next node)
+                      (cdr (undo-tree-node-next parent))))
+       (setq p (nthcdr (1- position) (undo-tree-node-next parent)))
+       (setcdr p (nconc (undo-tree-node-next node) (cddr p)))))
+    ;; update previous links of NODE's children
+    (dolist (n (undo-tree-node-next node))
+      (setf (undo-tree-node-previous n) parent))))
+
+
+(defun undo-tree-mapc (--undo-tree-mapc-function-- node)
+  ;; Apply FUNCTION to NODE and to each node below it.
+  (let ((stack (list node))
+       n)
+    (while stack
+      (setq n (pop stack))
+      (funcall --undo-tree-mapc-function-- n)
+      (setq stack (append (undo-tree-node-next n) stack)))))
+
+
+(defmacro undo-tree-num-branches ()
+  "Return number of branches at current undo tree node."
+  '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree))))
+
+
+(defun undo-tree-position (node list)
+  "Find the first occurrence of NODE in LIST.
+Return the index of the matching item, or nil of not found.
+Comparison is done with `eq'."
+  (let ((i 0))
+    (catch 'found
+      (while (progn
+               (when (eq node (car list)) (throw 'found i))
+               (incf i)
+               (setq list (cdr list))))
+      nil)))
+
+
+(defvar *undo-tree-id-counter* 0)
+(make-variable-buffer-local '*undo-tree-id-counter*)
+
+(defmacro undo-tree-generate-id ()
+  ;; Generate a new, unique id (uninterned symbol).
+  ;; The name is made by appending a number to "undo-tree-id".
+  ;; (Copied from CL package `gensym'.)
+  `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*))))
+     (make-symbol (format "undo-tree-id%d" num))))
+
+
+(defun undo-tree-decircle (undo-tree)
+  ;; Nullify PREVIOUS links of UNDO-TREE nodes, to make UNDO-TREE data
+  ;; structure non-circular.
+  (undo-tree-mapc
+   (lambda (node)
+     (dolist (n (undo-tree-node-next node))
+       (setf (undo-tree-node-previous n) nil)))
+   (undo-tree-root undo-tree)))
+
+
+(defun undo-tree-recircle (undo-tree)
+  ;; Recreate PREVIOUS links of UNDO-TREE nodes, to restore circular UNDO-TREE
+  ;; data structure.
+  (undo-tree-mapc
+   (lambda (node)
+     (dolist (n (undo-tree-node-next node))
+       (setf (undo-tree-node-previous n) node)))
+   (undo-tree-root undo-tree)))
+
+
+
+\f
+;;; =====================================================================
+;;;             Undo list and undo changeset utility functions
+
+(defmacro undo-list-marker-elt-p (elt)
+  `(markerp (car-safe ,elt)))
+
+(defmacro undo-list-GCd-marker-elt-p (elt)
+  ;; Return t if ELT is a marker element whose marker has been moved to the
+  ;; object-pool, so may potentially have been garbage-collected.
+  ;; Note: Valid marker undo elements should be uniquely identified as cons
+  ;; cells with a symbol in the car (replacing the marker), and a number in
+  ;; the cdr. However, to guard against future changes to undo element
+  ;; formats, we perform an additional redundant check on the symbol name.
+  `(and (car-safe ,elt)
+       (symbolp (car ,elt))
+       (let ((str (symbol-name (car ,elt))))
+         (and (> (length str) 12)
+              (string= (substring str 0 12) "undo-tree-id")))
+       (numberp (cdr-safe ,elt))))
+
+
+(defun undo-tree-move-GC-elts-to-pool (elt)
+  ;; Move elements that can be garbage-collected into `buffer-undo-tree'
+  ;; object pool, substituting a unique id that can be used to retrieve them
+  ;; later. (Only markers require this treatment currently.)
+  (when (undo-list-marker-elt-p elt)
+    (let ((id (undo-tree-generate-id)))
+      (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree))
+      (setcar elt id))))
+
+
+(defun undo-tree-restore-GC-elts-from-pool (elt)
+  ;; Replace object id's in ELT with corresponding objects from
+  ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if
+  ;; any object in ELT has been garbage-collected.
+  (if (undo-list-GCd-marker-elt-p elt)
+      (when (setcar elt (gethash (car elt)
+                                (undo-tree-object-pool buffer-undo-tree)))
+       elt)
+    elt))
+
+
+(defun undo-list-clean-GCd-elts (undo-list)
+  ;; Remove object id's from UNDO-LIST that refer to elements that have been
+  ;; garbage-collected. UNDO-LIST is modified by side-effect.
+  (while (undo-list-GCd-marker-elt-p (car undo-list))
+    (unless (gethash (caar undo-list)
+                    (undo-tree-object-pool buffer-undo-tree))
+      (setq undo-list (cdr undo-list))))
+  (let ((p undo-list))
+    (while (cdr p)
+      (when (and (undo-list-GCd-marker-elt-p (cadr p))
+                (null (gethash (car (cadr p))
+                               (undo-tree-object-pool buffer-undo-tree))))
+       (setcdr p (cddr p)))
+      (setq p (cdr p))))
+  undo-list)
+
+
+(defun undo-list-pop-changeset (&optional discard-pos)
+  ;; Pop changeset from `buffer-undo-list'. If DISCARD-POS is non-nil, discard
+  ;; any position entries from changeset.
+
+  ;; discard undo boundaries and (if DISCARD-POS is non-nil) position entries
+  ;; at head of undo list
+  (while (or (null (car buffer-undo-list))
+            (and discard-pos (integerp (car buffer-undo-list))))
+    (setq buffer-undo-list (cdr buffer-undo-list)))
+  ;; pop elements up to next undo boundary, discarding position entries if
+  ;; DISCARD-POS is non-nil
+  (if (eq (car buffer-undo-list) 'undo-tree-canary)
+      (push nil buffer-undo-list)
+    (let* ((changeset (list (pop buffer-undo-list)))
+           (p changeset))
+      (while (progn
+              (undo-tree-move-GC-elts-to-pool (car p))
+              (while (and discard-pos (integerp (car buffer-undo-list)))
+                (setq buffer-undo-list (cdr buffer-undo-list)))
+              (and (car buffer-undo-list)
+                   (not (eq (car buffer-undo-list) 'undo-tree-canary))))
+        (setcdr p (list (pop buffer-undo-list)))
+       (setq p (cdr p)))
+      changeset)))
+
+
+(defun undo-tree-copy-list (undo-list)
+  ;; Return a deep copy of first changeset in `undo-list'. Object id's are
+  ;; replaced by corresponding objects from `buffer-undo-tree' object-pool.
+  (when undo-list
+    (let (copy p)
+      ;; if first element contains an object id, replace it with object from
+      ;; pool, discarding element entirely if it's been GC'd
+      (while (null copy)
+       (setq copy
+             (undo-tree-restore-GC-elts-from-pool (pop undo-list))))
+      (setq copy (list copy)
+           p copy)
+      ;; copy remaining elements, replacing object id's with objects from
+      ;; pool, or discarding them entirely if they've been GC'd
+      (while undo-list
+       (when (setcdr p (undo-tree-restore-GC-elts-from-pool
+                        (undo-copy-list-1 (pop undo-list))))
+         (setcdr p (list (cdr p)))
+         (setq p (cdr p))))
+      copy)))
+
+
+
+(defun undo-list-transfer-to-tree ()
+  ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'.
+
+  ;; `undo-list-transfer-to-tree' should never be called when undo is disabled
+  ;; (i.e. `buffer-undo-tree' is t)
+  (assert (not (eq buffer-undo-tree t)))
+
+  ;; if `buffer-undo-tree' is empty, create initial undo-tree
+  (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree)))
+  ;; make sure there's a canary at end of `buffer-undo-list'
+  (when (null buffer-undo-list)
+    (setq buffer-undo-list '(nil undo-tree-canary)))
+
+  (unless (or (eq (cadr buffer-undo-list) 'undo-tree-canary)
+             (eq (car buffer-undo-list) 'undo-tree-canary))
+    ;; create new node from first changeset in `buffer-undo-list', save old
+    ;; `buffer-undo-tree' current node, and make new node the current node
+    (let* ((node (undo-tree-make-node nil (undo-list-pop-changeset)))
+          (splice (undo-tree-current buffer-undo-tree))
+          (size (undo-list-byte-size (undo-tree-node-undo node)))
+          (count 1))
+      (setf (undo-tree-current buffer-undo-tree) node)
+      ;; grow tree fragment backwards using `buffer-undo-list' changesets
+      (while (and buffer-undo-list
+                 (not (eq (cadr buffer-undo-list) 'undo-tree-canary)))
+       (setq node
+             (undo-tree-grow-backwards node (undo-list-pop-changeset)))
+       (incf size (undo-list-byte-size (undo-tree-node-undo node)))
+       (incf count))
+      ;; if no undo history has been discarded from `buffer-undo-list' since
+      ;; last transfer, splice new tree fragment onto end of old
+      ;; `buffer-undo-tree' current node
+      (if (or (eq (cadr buffer-undo-list) 'undo-tree-canary)
+             (eq (car buffer-undo-list) 'undo-tree-canary))
+         (progn
+           (setf (undo-tree-node-previous node) splice)
+           (push node (undo-tree-node-next splice))
+           (setf (undo-tree-node-branch splice) 0)
+           (incf (undo-tree-size buffer-undo-tree) size)
+           (incf (undo-tree-count buffer-undo-tree) count))
+       ;; if undo history has been discarded, replace entire
+       ;; `buffer-undo-tree' with new tree fragment
+       (setq node (undo-tree-grow-backwards node nil))
+       (setf (undo-tree-root buffer-undo-tree) node)
+       (setq buffer-undo-list '(nil undo-tree-canary))
+       (setf (undo-tree-size buffer-undo-tree) size)
+       (setf (undo-tree-count buffer-undo-tree) count)
+       (setq buffer-undo-list '(nil undo-tree-canary))))
+    ;; discard undo history if necessary
+    (undo-tree-discard-history)))
+
+
+(defun undo-list-byte-size (undo-list)
+  ;; Return size (in bytes) of UNDO-LIST
+  (let ((size 0) (p undo-list))
+    (while p
+      (incf size 8)  ; cons cells use up 8 bytes
+      (when (and (consp (car p)) (stringp (caar p)))
+        (incf size (string-bytes (caar p))))
+      (setq p (cdr p)))
+    size))
+
+
+
+(defun undo-list-rebuild-from-tree ()
+  "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'."
+  (unless (eq buffer-undo-list t)
+    (undo-list-transfer-to-tree)
+    (setq buffer-undo-list nil)
+    (when buffer-undo-tree
+      (let ((stack (list (list (undo-tree-root buffer-undo-tree)))))
+       (push (sort (mapcar 'identity (undo-tree-node-next (caar stack)))
+                   (lambda (a b)
+                     (time-less-p (undo-tree-node-timestamp a)
+                                  (undo-tree-node-timestamp b))))
+             stack)
+       ;; Traverse tree in depth-and-oldest-first order, but add undo records
+       ;; on the way down, and redo records on the way up.
+       (while (or (car stack)
+                  (not (eq (car (nth 1 stack))
+                           (undo-tree-current buffer-undo-tree))))
+         (if (car stack)
+             (progn
+               (setq buffer-undo-list
+                     (append (undo-tree-node-undo (caar stack))
+                             buffer-undo-list))
+               (undo-boundary)
+               (push (sort (mapcar 'identity
+                                   (undo-tree-node-next (caar stack)))
+                           (lambda (a b)
+                             (time-less-p (undo-tree-node-timestamp a)
+                                          (undo-tree-node-timestamp b))))
+                     stack))
+           (pop stack)
+           (setq buffer-undo-list
+                 (append (undo-tree-node-redo (caar stack))
+                         buffer-undo-list))
+           (undo-boundary)
+           (pop (car stack))))))))
+
+
+
+\f
+;;; =====================================================================
+;;;                History discarding utility functions
+
+(defun undo-tree-oldest-leaf (node)
+  ;; Return oldest leaf node below NODE.
+  (while (undo-tree-node-next node)
+    (setq node
+          (car (sort (mapcar 'identity (undo-tree-node-next node))
+                     (lambda (a b)
+                       (time-less-p (undo-tree-node-timestamp a)
+                                    (undo-tree-node-timestamp b)))))))
+  node)
+
+
+(defun undo-tree-discard-node (node)
+  ;; Discard NODE from `buffer-undo-tree', and return next in line for
+  ;; discarding.
+
+  ;; don't discard current node
+  (unless (eq node (undo-tree-current buffer-undo-tree))
+
+    ;; discarding root node...
+    (if (eq node (undo-tree-root buffer-undo-tree))
+        (cond
+         ;; should always discard branches before root
+         ((> (length (undo-tree-node-next node)) 1)
+          (error "Trying to discard undo-tree root which still\
+ has multiple branches"))
+         ;; don't discard root if current node is only child
+         ((eq (car (undo-tree-node-next node))
+              (undo-tree-current buffer-undo-tree))
+         nil)
+        ;; discard root
+         (t
+         ;; clear any register referring to root
+         (let ((r (undo-tree-node-register node)))
+           (when (and r (eq (get-register r) node))
+             (set-register r nil)))
+          ;; make child of root into new root
+          (setq node (setf (undo-tree-root buffer-undo-tree)
+                           (car (undo-tree-node-next node))))
+         ;; update undo-tree size
+         (decf (undo-tree-size buffer-undo-tree)
+               (+ (undo-list-byte-size (undo-tree-node-undo node))
+                  (undo-list-byte-size (undo-tree-node-redo node))))
+         (decf (undo-tree-count buffer-undo-tree))
+         ;; discard new root's undo data and PREVIOUS link
+         (setf (undo-tree-node-undo node) nil
+               (undo-tree-node-redo node) nil
+               (undo-tree-node-previous node) nil)
+          ;; if new root has branches, or new root is current node, next node
+          ;; to discard is oldest leaf, otherwise it's new root
+          (if (or (> (length (undo-tree-node-next node)) 1)
+                  (eq (car (undo-tree-node-next node))
+                      (undo-tree-current buffer-undo-tree)))
+              (undo-tree-oldest-leaf node)
+            node)))
+
+      ;; discarding leaf node...
+      (let* ((parent (undo-tree-node-previous node))
+             (current (nth (undo-tree-node-branch parent)
+                           (undo-tree-node-next parent))))
+       ;; clear any register referring to the discarded node
+       (let ((r (undo-tree-node-register node)))
+         (when (and r (eq (get-register r) node))
+           (set-register r nil)))
+       ;; update undo-tree size
+       (decf (undo-tree-size buffer-undo-tree)
+             (+ (undo-list-byte-size (undo-tree-node-undo node))
+                (undo-list-byte-size (undo-tree-node-redo node))))
+       (decf (undo-tree-count buffer-undo-tree))
+       ;; discard leaf
+        (setf (undo-tree-node-next parent)
+                (delq node (undo-tree-node-next parent))
+              (undo-tree-node-branch parent)
+                (undo-tree-position current (undo-tree-node-next parent)))
+        ;; if parent has branches, or parent is current node, next node to
+        ;; discard is oldest leaf, otherwise it's the parent itself
+        (if (or (eq parent (undo-tree-current buffer-undo-tree))
+                (and (undo-tree-node-next parent)
+                     (or (not (eq parent (undo-tree-root buffer-undo-tree)))
+                         (> (length (undo-tree-node-next parent)) 1))))
+            (undo-tree-oldest-leaf parent)
+          parent)))))
+
+
+
+(defun undo-tree-discard-history ()
+  "Discard undo history until we're within memory usage limits
+set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'."
+
+  (when (> (undo-tree-size buffer-undo-tree) undo-limit)
+    ;; if there are no branches off root, first node to discard is root;
+    ;; otherwise it's leaf node at botom of oldest branch
+    (let ((node (if (> (length (undo-tree-node-next
+                                (undo-tree-root buffer-undo-tree))) 1)
+                    (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree))
+                  (undo-tree-root buffer-undo-tree))))
+
+      ;; discard nodes until memory use is within `undo-strong-limit'
+      (while (and node
+                  (> (undo-tree-size buffer-undo-tree) undo-strong-limit))
+        (setq node (undo-tree-discard-node node)))
+
+      ;; discard nodes until next node to discard would bring memory use
+      ;; within `undo-limit'
+      (while (and node
+                 ;; check first if last discard has brought us within
+                 ;; `undo-limit', in case we can avoid more expensive
+                 ;; `undo-strong-limit' calculation
+                 ;; Note: this assumes undo-strong-limit > undo-limit;
+                 ;;       if not, effectively undo-strong-limit = undo-limit
+                 (> (undo-tree-size buffer-undo-tree) undo-limit)
+                  (> (- (undo-tree-size buffer-undo-tree)
+                       ;; if next node to discard is root, the memory we
+                       ;; free-up comes from discarding changesets from its
+                       ;; only child...
+                       (if (eq node (undo-tree-root buffer-undo-tree))
+                           (+ (undo-list-byte-size
+                               (undo-tree-node-undo
+                                (car (undo-tree-node-next node))))
+                              (undo-list-byte-size
+                               (undo-tree-node-redo
+                                (car (undo-tree-node-next node)))))
+                         ;; ...otherwise, it comes from discarding changesets
+                         ;; from along with the node itself
+                         (+ (undo-list-byte-size (undo-tree-node-undo node))
+                            (undo-list-byte-size (undo-tree-node-redo node)))
+                         ))
+                     undo-limit))
+        (setq node (undo-tree-discard-node node)))
+
+      ;; if we're still over the `undo-outer-limit', discard entire history
+      (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit)
+        ;; query first if `undo-ask-before-discard' is set
+        (if undo-ask-before-discard
+            (when (yes-or-no-p
+                   (format
+                    "Buffer `%s' undo info is %d bytes long;  discard it? "
+                    (buffer-name) (undo-tree-size buffer-undo-tree)))
+              (setq buffer-undo-tree nil))
+          ;; otherwise, discard and display warning
+          (display-warning
+           '(undo discard-info)
+           (concat
+            (format "Buffer `%s' undo info was %d bytes long.\n"
+                    (buffer-name) (undo-tree-size buffer-undo-tree))
+            "The undo info was discarded because it exceeded\
+ `undo-outer-limit'.
+
+This is normal if you executed a command that made a huge change
+to the buffer. In that case, to prevent similar problems in the
+future, set `undo-outer-limit' to a value that is large enough to
+cover the maximum size of normal changes you expect a single
+command to make, but not so large that it might exceed the
+maximum memory allotted to Emacs.
+
+If you did not execute any such command, the situation is
+probably due to a bug and you should report it.
+
+You can disable the popping up of this buffer by adding the entry
+\(undo discard-info) to the user option `warning-suppress-types',
+which is defined in the `warnings' library.\n")
+           :warning)
+          (setq buffer-undo-tree nil)))
+      )))
+
+
+
+\f
+;;; =====================================================================
+;;;                   Visualizer utility functions
+
+(defun undo-tree-compute-widths (node)
+  "Recursively compute widths for nodes below NODE."
+  (let ((stack (list node))
+        res)
+    (while stack
+      ;; try to compute widths for node at top of stack
+      (if (undo-tree-node-p
+           (setq res (undo-tree-node-compute-widths (car stack))))
+          ;; if computation fails, it returns a node whose widths still need
+          ;; computing, which we push onto the stack
+          (push res stack)
+        ;; otherwise, store widths and remove it from stack
+        (setf (undo-tree-node-lwidth (car stack)) (aref res 0)
+              (undo-tree-node-cwidth (car stack)) (aref res 1)
+              (undo-tree-node-rwidth (car stack)) (aref res 2))
+        (pop stack)))))
+
+
+(defun undo-tree-node-compute-widths (node)
+  ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths
+  ;; (in a vector) if successful. Otherwise, returns a node whose widths need
+  ;; calculating before NODE's can be calculated.
+  (let ((num-children (length (undo-tree-node-next node)))
+        (lwidth 0) (cwidth 0) (rwidth 0) p)
+    (catch 'need-widths
+      (cond
+       ;; leaf nodes have 0 width
+       ((= 0 num-children)
+        (setf cwidth 1
+              (undo-tree-node-lwidth node) 0
+              (undo-tree-node-cwidth node) 1
+              (undo-tree-node-rwidth node) 0))
+
+       ;; odd number of children
+       ((= (mod num-children 2) 1)
+        (setq p (undo-tree-node-next node))
+        ;; compute left-width
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf lwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            ;; if child's widths haven't been computed, return that child
+            (throw 'need-widths (car p)))
+          (setq p (cdr p)))
+        (if (undo-tree-node-lwidth (car p))
+            (incf lwidth (undo-tree-node-lwidth (car p)))
+          (throw 'need-widths (car p)))
+        ;; centre-width is inherited from middle child
+        (setf cwidth (undo-tree-node-cwidth (car p)))
+        ;; compute right-width
+        (incf rwidth (undo-tree-node-rwidth (car p)))
+        (setq p (cdr p))
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf rwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            (throw 'need-widths (car p)))
+          (setq p (cdr p))))
+
+       ;; even number of children
+       (t
+        (setq p (undo-tree-node-next node))
+        ;; compute left-width
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf lwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            (throw 'need-widths (car p)))
+          (setq p (cdr p)))
+        ;; centre-width is 0 when number of children is even
+        (setq cwidth 0)
+        ;; compute right-width
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf rwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            (throw 'need-widths (car p)))
+          (setq p (cdr p)))))
+
+      ;; return left-, centre- and right-widths
+      (vector lwidth cwidth rwidth))))
+
+
+(defun undo-tree-clear-visualizer-data (tree)
+  ;; Clear visualizer data below NODE.
+  (undo-tree-mapc
+   (lambda (n) (undo-tree-node-clear-visualizer-data n))
+   (undo-tree-root tree)))
+
+
+(defun undo-tree-node-unmodified-p (node &optional mtime)
+  ;; Return non-nil if NODE corresponds to a buffer state that once upon a
+  ;; time was unmodified. If a file modification time MTIME is specified,
+  ;; return non-nil if the corresponding buffer state really is unmodified.
+  (let (changeset ntime)
+    (setq changeset
+         (or (undo-tree-node-redo node)
+             (and (setq changeset (car (undo-tree-node-next node)))
+                  (undo-tree-node-undo changeset)))
+         ntime
+         (catch 'found
+           (dolist (elt changeset)
+             (when (and (consp elt) (eq (car elt) t) (consp (cdr elt))
+                        (throw 'found (cdr elt)))))))
+    (and ntime
+        (or (null mtime)
+            ;; high-precision timestamps
+            (if (listp (cdr ntime))
+                (equal ntime mtime)
+              ;; old-style timestamps
+              (and (= (car ntime) (car mtime))
+                   (= (cdr ntime) (cadr mtime))))))))
+
+
+
+\f
+;;; =====================================================================
+;;;                  Undo-in-region utility functions
+
+;; `undo-elt-in-region' uses this as a dynamically-scoped variable
+(defvar undo-adjusted-markers nil)
+
+
+(defun undo-tree-pull-undo-in-region-branch (start end)
+  ;; Pull out entries from undo changesets to create a new undo-in-region
+  ;; branch, which undoes changeset entries lying between START and END first,
+  ;; followed by remaining entries from the changesets, before rejoining the
+  ;; existing undo tree history. Repeated calls will, if appropriate, extend
+  ;; the current undo-in-region branch rather than creating a new one.
+
+  ;; if we're just reverting the last redo-in-region, we don't need to
+  ;; manipulate the undo tree at all
+  (if (undo-tree-reverting-redo-in-region-p start end)
+      t  ; return t to indicate success
+
+    ;; We build the `region-changeset' and `delta-list' lists forwards, using
+    ;; pointers `r' and `d' to the penultimate element of the list. So that we
+    ;; don't have to treat the first element differently, we prepend a dummy
+    ;; leading nil to the lists, and have the pointers point to that
+    ;; initially.
+    ;; Note: using '(nil) instead of (list nil) in the `let*' results in
+    ;;       bizarre errors when the code is byte-compiled, where parts of the
+    ;;       lists appear to survive across different calls to this function.
+    ;;       An obscure byte-compiler bug, perhaps?
+    (let* ((region-changeset (list nil))
+          (r region-changeset)
+          (delta-list (list nil))
+          (d delta-list)
+          (node (undo-tree-current buffer-undo-tree))
+          (repeated-undo-in-region
+           (undo-tree-repeated-undo-in-region-p start end))
+          undo-adjusted-markers  ; `undo-elt-in-region' expects this
+          fragment splice original-fragment original-splice original-current
+          got-visible-elt undo-list elt)
+
+      ;; --- initialisation ---
+      (cond
+       ;; if this is a repeated undo in the same region, start pulling changes
+       ;; from NODE at which undo-in-region branch iss attached, and detatch
+       ;; the branch, using it as initial FRAGMENT of branch being constructed
+       (repeated-undo-in-region
+       (setq original-current node
+             fragment (car (undo-tree-node-next node))
+             splice node)
+       ;; undo up to node at which undo-in-region branch is attached
+       ;; (recognizable as first node with more than one branch)
+       (let ((mark-active nil))
+         (while (= (length (undo-tree-node-next node)) 1)
+           (undo-tree-undo-1)
+           (setq fragment node
+                 node (undo-tree-current buffer-undo-tree))))
+       (when (eq splice node) (setq splice nil))
+       ;; detatch undo-in-region branch
+       (setf (undo-tree-node-next node)
+             (delq fragment (undo-tree-node-next node))
+             (undo-tree-node-previous fragment) nil
+             original-fragment fragment
+             original-splice node))
+
+       ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all
+       ;; nodes below the current one in the active branch
+       ((undo-tree-node-next node)
+       (setq fragment (undo-tree-make-node nil nil)
+             splice fragment)
+       (while (setq node (nth (undo-tree-node-branch node)
+                              (undo-tree-node-next node)))
+         (push (undo-tree-make-node
+                splice
+                (undo-copy-list (undo-tree-node-undo node))
+                (undo-copy-list (undo-tree-node-redo node)))
+               (undo-tree-node-next splice))
+         (setq splice (car (undo-tree-node-next splice))))
+       (setq fragment (car (undo-tree-node-next fragment))
+             splice nil
+             node (undo-tree-current buffer-undo-tree))))
+
+
+      ;; --- pull undo-in-region elements into branch ---
+      ;; work backwards up tree, pulling out undo elements within region until
+      ;; we've got one that undoes a visible change (insertion or deletion)
+      (catch 'abort
+       (while (and (not got-visible-elt) node (undo-tree-node-undo node))
+         ;; we cons a dummy nil element on the front of the changeset so that
+         ;; we can conveniently remove the first (real) element from the
+         ;; changeset if we need to; the leading nil is removed once we're
+         ;; done with this changeset
+         (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node)))
+               elt (cadr undo-list))
+         (if fragment
+             (progn
+               (setq fragment (undo-tree-grow-backwards fragment undo-list))
+               (unless splice (setq splice fragment)))
+           (setq fragment (undo-tree-make-node nil undo-list))
+           (setq splice fragment))
+
+         (while elt
+           (cond
+            ;; keep elements within region
+            ((undo-elt-in-region elt start end)
+             ;; set flag if kept element is visible (insertion or deletion)
+             (when (and (consp elt)
+                        (or (stringp (car elt)) (integerp (car elt))))
+               (setq got-visible-elt t))
+             ;; adjust buffer positions in elements previously undone before
+             ;; kept element, as kept element will now be undone first
+             (undo-tree-adjust-elements-to-elt splice elt)
+             ;; move kept element to undo-in-region changeset, adjusting its
+             ;; buffer position as it will now be undone first
+             (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list))))
+             (setq r (cdr r))
+             (setcdr undo-list (cddr undo-list)))
+
+            ;; discard "was unmodified" elements
+            ;; FIXME: deal properly with these
+            ((and (consp elt) (eq (car elt) t))
+             (setcdr undo-list (cddr undo-list)))
+
+            ;; if element crosses region, we can't pull any more elements
+            ((undo-elt-crosses-region elt start end)
+             ;; if we've found a visible element, it must be earlier in
+             ;; current node's changeset; stop pulling elements (null
+             ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit)
+             (if got-visible-elt
+                 (setq undo-list nil)
+               ;; if we haven't found a visible element yet, pulling
+               ;; undo-in-region branch has failed
+               (setq region-changeset nil)
+               (throw 'abort t)))
+
+            ;; if rejecting element, add its delta (if any) to the list
+            (t
+             (let ((delta (undo-delta elt)))
+               (when (/= 0 (cdr delta))
+                 (setcdr d (list delta))
+                 (setq d (cdr d))))
+             (setq undo-list (cdr undo-list))))
+
+           ;; process next element of current changeset
+           (setq elt (cadr undo-list)))
+
+         ;; if there are remaining elements in changeset, remove dummy nil
+         ;; from front
+         (if (cadr (undo-tree-node-undo fragment))
+             (pop (undo-tree-node-undo fragment))
+           ;; otherwise, if we've kept all elements in changeset, discard
+           ;; empty changeset
+           (when (eq splice fragment) (setq splice nil))
+           (setq fragment (car (undo-tree-node-next fragment))))
+         ;; process changeset from next node up the tree
+         (setq node (undo-tree-node-previous node))))
+
+      ;; pop dummy nil from front of `region-changeset'
+      (setq region-changeset (cdr region-changeset))
+
+
+      ;; --- integrate branch into tree ---
+      ;; if no undo-in-region elements were found, restore undo tree
+      (if (null region-changeset)
+         (when original-current
+           (push original-fragment (undo-tree-node-next original-splice))
+           (setf (undo-tree-node-branch original-splice) 0
+                 (undo-tree-node-previous original-fragment) original-splice)
+           (let ((mark-active nil))
+             (while (not (eq (undo-tree-current buffer-undo-tree)
+                             original-current))
+               (undo-tree-redo-1)))
+           nil)  ; return nil to indicate failure
+
+       ;; otherwise...
+       ;; need to undo up to node where new branch will be attached, to
+       ;; ensure redo entries are populated, and then redo back to where we
+       ;; started
+       (let ((mark-active nil)
+             (current (undo-tree-current buffer-undo-tree)))
+         (while (not (eq (undo-tree-current buffer-undo-tree) node))
+           (undo-tree-undo-1))
+         (while (not (eq (undo-tree-current buffer-undo-tree) current))
+           (undo-tree-redo-1)))
+
+       (cond
+        ;; if there's no remaining fragment, just create undo-in-region node
+        ;; and attach it to parent of last node from which elements were
+        ;; pulled
+        ((null fragment)
+         (setq fragment (undo-tree-make-node node region-changeset))
+         (push fragment (undo-tree-node-next node))
+         (setf (undo-tree-node-branch node) 0)
+         ;; set current node to undo-in-region node
+         (setf (undo-tree-current buffer-undo-tree) fragment))
+
+        ;; if no splice point has been set, add undo-in-region node to top of
+        ;; fragment and attach it to parent of last node from which elements
+        ;; were pulled
+        ((null splice)
+         (setq fragment (undo-tree-grow-backwards fragment region-changeset))
+         (push fragment (undo-tree-node-next node))
+         (setf (undo-tree-node-branch node) 0
+               (undo-tree-node-previous fragment) node)
+         ;; set current node to undo-in-region node
+         (setf (undo-tree-current buffer-undo-tree) fragment))
+
+        ;; if fragment contains nodes, attach fragment to parent of last node
+        ;; from which elements were pulled, and splice in undo-in-region node
+        (t
+         (setf (undo-tree-node-previous fragment) node)
+         (push fragment (undo-tree-node-next node))
+         (setf (undo-tree-node-branch node) 0)
+         ;; if this is a repeated undo-in-region, then we've left the current
+         ;; node at the original splice-point; we need to set the current
+         ;; node to the equivalent node on the undo-in-region branch and redo
+         ;; back to where we started
+         (when repeated-undo-in-region
+           (setf (undo-tree-current buffer-undo-tree)
+                 (undo-tree-node-previous original-fragment))
+           (let ((mark-active nil))
+             (while (not (eq (undo-tree-current buffer-undo-tree) splice))
+               (undo-tree-redo-1 nil 'preserve-undo))))
+         ;; splice new undo-in-region node into fragment
+         (setq node (undo-tree-make-node nil region-changeset))
+         (undo-tree-splice-node node splice)
+         ;; set current node to undo-in-region node
+         (setf (undo-tree-current buffer-undo-tree) node)))
+
+       ;; update undo-tree size
+       (setq node (undo-tree-node-previous fragment))
+       (while (progn
+                (and (setq node (car (undo-tree-node-next node)))
+                     (not (eq node original-fragment))
+                     (incf (undo-tree-count buffer-undo-tree))
+                     (incf (undo-tree-size buffer-undo-tree)
+                           (+ (undo-list-byte-size (undo-tree-node-undo node))
+                              (undo-list-byte-size (undo-tree-node-redo node)))))))
+       t)  ; indicate undo-in-region branch was successfully pulled
+      )))
+
+
+
+(defun undo-tree-pull-redo-in-region-branch (start end)
+  ;; Pull out entries from redo changesets to create a new redo-in-region
+  ;; branch, which redoes changeset entries lying between START and END first,
+  ;; followed by remaining entries from the changesets. Repeated calls will,
+  ;; if appropriate, extend the current redo-in-region branch rather than
+  ;; creating a new one.
+
+  ;; if we're just reverting the last undo-in-region, we don't need to
+  ;; manipulate the undo tree at all
+  (if (undo-tree-reverting-undo-in-region-p start end)
+      t  ; return t to indicate success
+
+    ;; We build the `region-changeset' and `delta-list' lists forwards, using
+    ;; pointers `r' and `d' to the penultimate element of the list. So that we
+    ;; don't have to treat the first element differently, we prepend a dummy
+    ;; leading nil to the lists, and have the pointers point to that
+    ;; initially.
+    ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre
+    ;;       errors when the code is byte-compiled, where parts of the lists
+    ;;       appear to survive across different calls to this function.  An
+    ;;       obscure byte-compiler bug, perhaps?
+    (let* ((region-changeset (list nil))
+          (r region-changeset)
+          (delta-list (list nil))
+          (d delta-list)
+          (node (undo-tree-current buffer-undo-tree))
+          (repeated-redo-in-region
+           (undo-tree-repeated-redo-in-region-p start end))
+          undo-adjusted-markers  ; `undo-elt-in-region' expects this
+          fragment splice got-visible-elt redo-list elt)
+
+      ;; --- inisitalisation ---
+      (cond
+       ;; if this is a repeated redo-in-region, detach fragment below current
+       ;; node
+       (repeated-redo-in-region
+       (when (setq fragment (car (undo-tree-node-next node)))
+         (setf (undo-tree-node-previous fragment) nil
+               (undo-tree-node-next node)
+               (delq fragment (undo-tree-node-next node)))))
+       ;; if this is a new redo-in-region, initial fragment is a copy of all
+       ;; nodes below the current one in the active branch
+       ((undo-tree-node-next node)
+       (setq fragment (undo-tree-make-node nil nil)
+             splice fragment)
+       (while (setq node (nth (undo-tree-node-branch node)
+                              (undo-tree-node-next node)))
+         (push (undo-tree-make-node
+                splice nil
+                (undo-copy-list (undo-tree-node-redo node)))
+               (undo-tree-node-next splice))
+         (setq splice (car (undo-tree-node-next splice))))
+       (setq fragment (car (undo-tree-node-next fragment)))))
+
+
+      ;; --- pull redo-in-region elements into branch ---
+      ;; work down fragment, pulling out redo elements within region until
+      ;; we've got one that redoes a visible change (insertion or deletion)
+      (setq node fragment)
+      (catch 'abort
+       (while (and (not got-visible-elt) node (undo-tree-node-redo node))
+         ;; we cons a dummy nil element on the front of the changeset so that
+         ;; we can conveniently remove the first (real) element from the
+         ;; changeset if we need to; the leading nil is removed once we're
+         ;; done with this changeset
+         (setq redo-list (push nil (undo-tree-node-redo node))
+               elt (cadr redo-list))
+         (while elt
+           (cond
+            ;; keep elements within region
+            ((undo-elt-in-region elt start end)
+             ;; set flag if kept element is visible (insertion or deletion)
+             (when (and (consp elt)
+                        (or (stringp (car elt)) (integerp (car elt))))
+               (setq got-visible-elt t))
+             ;; adjust buffer positions in elements previously redone before
+             ;; kept element, as kept element will now be redone first
+             (undo-tree-adjust-elements-to-elt fragment elt t)
+             ;; move kept element to redo-in-region changeset, adjusting its
+             ;; buffer position as it will now be redone first
+             (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1)))
+             (setq r (cdr r))
+             (setcdr redo-list (cddr redo-list)))
+
+            ;; discard "was unmodified" elements
+            ;; FIXME: deal properly with these
+            ((and (consp elt) (eq (car elt) t))
+             (setcdr redo-list (cddr redo-list)))
+
+            ;; if element crosses region, we can't pull any more elements
+            ((undo-elt-crosses-region elt start end)
+             ;; if we've found a visible element, it must be earlier in
+             ;; current node's changeset; stop pulling elements (null
+             ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit)
+             (if got-visible-elt
+                 (setq redo-list nil)
+               ;; if we haven't found a visible element yet, pulling
+               ;; redo-in-region branch has failed
+               (setq region-changeset nil)
+               (throw 'abort t)))
+
+            ;; if rejecting element, add its delta (if any) to the list
+            (t
+             (let ((delta (undo-delta elt)))
+               (when (/= 0 (cdr delta))
+                 (setcdr d (list delta))
+                 (setq d (cdr d))))
+             (setq redo-list (cdr redo-list))))
+
+           ;; process next element of current changeset
+           (setq elt (cadr redo-list)))
+
+         ;; if there are remaining elements in changeset, remove dummy nil
+         ;; from front
+         (if (cadr (undo-tree-node-redo node))
+             (pop (undo-tree-node-undo node))
+           ;; otherwise, if we've kept all elements in changeset, discard
+           ;; empty changeset
+           (if (eq fragment node)
+               (setq fragment (car (undo-tree-node-next fragment)))
+             (undo-tree-snip-node node)))
+         ;; process changeset from next node in fragment
+         (setq node (car (undo-tree-node-next node)))))
+
+      ;; pop dummy nil from front of `region-changeset'
+      (setq region-changeset (cdr region-changeset))
+
+
+      ;; --- integrate branch into tree ---
+      (setq node (undo-tree-current buffer-undo-tree))
+      ;; if no redo-in-region elements were found, restore undo tree
+      (if (null (car region-changeset))
+         (when (and repeated-redo-in-region fragment)
+           (push fragment (undo-tree-node-next node))
+           (setf (undo-tree-node-branch node) 0
+                 (undo-tree-node-previous fragment) node)
+           nil)  ; return nil to indicate failure
+
+       ;; otherwise, add redo-in-region node to top of fragment, and attach
+       ;; it below current node
+       (setq fragment
+             (if fragment
+                 (undo-tree-grow-backwards fragment nil region-changeset)
+               (undo-tree-make-node nil nil region-changeset)))
+       (push fragment (undo-tree-node-next node))
+       (setf (undo-tree-node-branch node) 0
+             (undo-tree-node-previous fragment) node)
+       ;; update undo-tree size
+       (unless repeated-redo-in-region
+         (setq node fragment)
+         (while (and (setq node (car (undo-tree-node-next node)))
+                     (incf (undo-tree-count buffer-undo-tree))
+                     (incf (undo-tree-size buffer-undo-tree)
+                           (undo-list-byte-size
+                            (undo-tree-node-redo node))))))
+       (incf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-redo fragment)))
+       t)  ; indicate redo-in-region branch was successfully pulled
+      )))
+
+
+
+(defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below)
+  "Adjust buffer positions of undo elements, starting at NODE's
+and going up the tree (or down the active branch if BELOW is
+non-nil) and through the nodes' undo elements until we reach
+UNDO-ELT.  UNDO-ELT must appear somewhere in the undo changeset
+of either NODE itself or some node above it in the tree."
+  (let ((delta (list (undo-delta undo-elt)))
+       (undo-list (undo-tree-node-undo node)))
+    ;; adjust elements until we reach UNDO-ELT
+    (while (and (car undo-list)
+               (not (eq (car undo-list) undo-elt)))
+      (setcar undo-list
+             (undo-tree-apply-deltas (car undo-list) delta -1))
+      ;; move to next undo element in list, or to next node if we've run out
+      ;; of elements
+      (unless (car (setq undo-list (cdr undo-list)))
+       (if below
+           (setq node (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node)))
+         (setq node (undo-tree-node-previous node)))
+       (setq undo-list (undo-tree-node-undo node))))))
+
+
+
+(defun undo-tree-apply-deltas (undo-elt deltas &optional sgn)
+  ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN
+  ;; (only useful value for SGN is -1).
+  (let (position offset)
+    (dolist (delta deltas)
+      (setq position (car delta)
+           offset (* (cdr delta) (or sgn 1)))
+      (cond
+       ;; POSITION
+       ((integerp undo-elt)
+       (when (>= undo-elt position)
+         (setq undo-elt (- undo-elt offset))))
+       ;; nil (or any other atom)
+       ((atom undo-elt))
+       ;; (TEXT . POSITION)
+       ((stringp (car undo-elt))
+       (let ((text-pos (abs (cdr undo-elt)))
+             (point-at-end (< (cdr undo-elt) 0)))
+         (if (>= text-pos position)
+             (setcdr undo-elt (* (if point-at-end -1 1)
+                                 (- text-pos offset))))))
+       ;; (BEGIN . END)
+       ((integerp (car undo-elt))
+       (when (>= (car undo-elt) position)
+         (setcar undo-elt (- (car undo-elt) offset))
+         (setcdr undo-elt (- (cdr undo-elt) offset))))
+       ;; (nil PROPERTY VALUE BEG . END)
+       ((null (car undo-elt))
+       (let ((tail (nthcdr 3 undo-elt)))
+         (when (>= (car tail) position)
+           (setcar tail (- (car tail) offset))
+           (setcdr tail (- (cdr tail) offset)))))
+       ))
+    undo-elt))
+
+
+
+(defun undo-tree-repeated-undo-in-region-p (start end)
+  ;; Return non-nil if undo-in-region between START and END is a repeated
+  ;; undo-in-region
+  (let ((node (undo-tree-current buffer-undo-tree)))
+    (and (setq node
+              (nth (undo-tree-node-branch node) (undo-tree-node-next node)))
+        (eq (undo-tree-node-undo-beginning node) start)
+        (eq (undo-tree-node-undo-end node) end))))
+
+
+(defun undo-tree-repeated-redo-in-region-p (start end)
+  ;; Return non-nil if undo-in-region between START and END is a repeated
+  ;; undo-in-region
+  (let ((node (undo-tree-current buffer-undo-tree)))
+    (and (eq (undo-tree-node-redo-beginning node) start)
+        (eq (undo-tree-node-redo-end node) end))))
+
+
+;; Return non-nil if undo-in-region between START and END is simply
+;; reverting the last redo-in-region
+(defalias 'undo-tree-reverting-undo-in-region-p
+  'undo-tree-repeated-undo-in-region-p)
+
+
+;; Return non-nil if redo-in-region between START and END is simply
+;; reverting the last undo-in-region
+(defalias 'undo-tree-reverting-redo-in-region-p
+  'undo-tree-repeated-redo-in-region-p)
+
+
+
+\f
+;;; =====================================================================
+;;;                        Undo-tree commands
+
+;;;###autoload
+(define-minor-mode undo-tree-mode
+  "Toggle undo-tree mode.
+With no argument, this command toggles the mode.
+A positive prefix argument turns the mode on.
+A negative prefix argument turns it off.
+
+Undo-tree-mode replaces Emacs' standard undo feature with a more
+powerful yet easier to use version, that treats the undo history
+as what it is: a tree.
+
+The following keys are available in `undo-tree-mode':
+
+  \\{undo-tree-map}
+
+Within the undo-tree visualizer, the following keys are available:
+
+  \\{undo-tree-visualizer-map}"
+
+  nil                       ; init value
+  undo-tree-mode-lighter    ; lighter
+  undo-tree-map             ; keymap
+
+  ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so
+  ;; Emacs undo can work
+  (if (not undo-tree-mode)
+    (undo-list-rebuild-from-tree)
+    (setq buffer-undo-tree nil)))
+
+
+(defun turn-on-undo-tree-mode (&optional print-message)
+  "Enable `undo-tree-mode' in the current buffer, when appropriate.
+Some major modes implement their own undo system, which should
+not normally be overridden by `undo-tree-mode'. This command does
+not enable `undo-tree-mode' in such buffers. If you want to force
+`undo-tree-mode' to be enabled regardless, use (undo-tree-mode 1)
+instead.
+
+The heuristic used to detect major modes in which
+`undo-tree-mode' should not be used is to check whether either
+the `undo' command has been remapped, or the default undo
+keybindings (C-/ and C-_) have been overridden somewhere other
+than in the global map. In addition, `undo-tree-mode' will not be
+enabled if the buffer's `major-mode' appears in
+`undo-tree-incompatible-major-modes'."
+  (interactive "p")
+  (if (or (key-binding [remap undo])
+         (undo-tree-overridden-undo-bindings-p)
+         (memq major-mode undo-tree-incompatible-major-modes))
+      (when print-message
+       (message "Buffer does not support undo-tree-mode;\
+ undo-tree-mode NOT enabled"))
+    (undo-tree-mode 1)))
+
+
+(defun undo-tree-overridden-undo-bindings-p ()
+  "Returns t if default undo bindings are overridden, nil otherwise.
+Checks if either of the default undo key bindings (\"C-/\" or
+\"C-_\") are overridden in the current buffer by any keymap other
+than the global one. (So global redefinitions of the default undo
+key bindings do not count.)"
+  (let ((binding1 (lookup-key (current-global-map) [?\C-/]))
+       (binding2 (lookup-key (current-global-map) [?\C-_])))
+    (global-set-key [?\C-/] 'undo)
+    (global-set-key [?\C-_] 'undo)
+    (unwind-protect
+       (or (and (key-binding [?\C-/])
+                (not (eq (key-binding [?\C-/]) 'undo)))
+           (and (key-binding [?\C-_])
+                (not (eq (key-binding [?\C-_]) 'undo))))
+      (global-set-key [?\C-/] binding1)
+      (global-set-key [?\C-_] binding2))))
+
+
+;;;###autoload
+(define-globalized-minor-mode global-undo-tree-mode
+  undo-tree-mode turn-on-undo-tree-mode)
+
+
+
+(defun undo-tree-undo (&optional arg)
+  "Undo changes.
+Repeat this command to undo more changes.
+A numeric ARG serves as a repeat count.
+
+In Transient Mark mode when the mark is active, only undo changes
+within the current region. Similarly, when not in Transient Mark
+mode, just \\[universal-argument] as an argument limits undo to
+changes within the current region."
+  (interactive "*P")
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t)
+    (user-error "No undo information in this buffer"))
+  (undo-tree-undo-1 arg)
+  ;; inform user if at branch point
+  (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))
+
+
+(defun undo-tree-undo-1 (&optional arg preserve-redo preserve-timestamps)
+  ;; Internal undo function. An active mark in `transient-mark-mode', or
+  ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-REDO
+  ;; causes the existing redo record to be preserved, rather than replacing it
+  ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS
+  ;; disables updating of timestamps in visited undo-tree nodes. (This latter
+  ;; should *only* be used when temporarily visiting another undo state and
+  ;; immediately returning to the original state afterwards. Otherwise, it
+  ;; could cause history-discarding errors.)
+  (let ((undo-in-progress t)
+       (undo-in-region (and undo-tree-enable-undo-in-region
+                            (or (region-active-p)
+                                (and arg (not (numberp arg))))))
+       pos current)
+    ;; transfer entries accumulated in `buffer-undo-list' to
+    ;; `buffer-undo-tree'
+    (undo-list-transfer-to-tree)
+
+    (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
+      ;; check if at top of undo tree
+      (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
+       (user-error "No further undo information"))
+
+      ;; if region is active, or a non-numeric prefix argument was supplied,
+      ;; try to pull out a new branch of changes affecting the region
+      (when (and undo-in-region
+                (not (undo-tree-pull-undo-in-region-branch
+                      (region-beginning) (region-end))))
+       (user-error "No further undo information for region"))
+
+      ;; remove any GC'd elements from node's undo list
+      (setq current (undo-tree-current buffer-undo-tree))
+      (decf (undo-tree-size buffer-undo-tree)
+           (undo-list-byte-size (undo-tree-node-undo current)))
+      (setf (undo-tree-node-undo current)
+           (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
+      (incf (undo-tree-size buffer-undo-tree)
+           (undo-list-byte-size (undo-tree-node-undo current)))
+      ;; undo one record from undo tree
+      (when undo-in-region
+       (setq pos (set-marker (make-marker) (point)))
+       (set-marker-insertion-type pos t))
+      (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current)))
+      (undo-boundary)
+
+      ;; if preserving old redo record, discard new redo entries that
+      ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
+      ;; elements from node's redo list
+      (if preserve-redo
+         (progn
+           (undo-list-pop-changeset)
+           (decf (undo-tree-size buffer-undo-tree)
+                 (undo-list-byte-size (undo-tree-node-redo current)))
+           (setf (undo-tree-node-redo current)
+                 (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
+           (incf (undo-tree-size buffer-undo-tree)
+                 (undo-list-byte-size (undo-tree-node-redo current))))
+       ;; otherwise, record redo entries that `primitive-undo' has added to
+       ;; `buffer-undo-list' in current node's redo record, replacing
+       ;; existing entry if one already exists
+       (decf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-redo current)))
+       (setf (undo-tree-node-redo current)
+             (undo-list-pop-changeset 'discard-pos))
+       (incf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-redo current))))
+
+      ;; rewind current node and update timestamp
+      (setf (undo-tree-current buffer-undo-tree)
+           (undo-tree-node-previous (undo-tree-current buffer-undo-tree)))
+      (unless preserve-timestamps
+       (setf (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree))
+             (current-time)))
+
+      ;; if undoing-in-region, record current node, region and direction so we
+      ;; can tell if undo-in-region is repeated, and re-activate mark if in
+      ;; `transient-mark-mode'; if not, erase any leftover data
+      (if (not undo-in-region)
+         (undo-tree-node-clear-region-data current)
+       (goto-char pos)
+       ;; note: we deliberately want to store the region information in the
+       ;; node *below* the now current one
+       (setf (undo-tree-node-undo-beginning current) (region-beginning)
+             (undo-tree-node-undo-end current) (region-end))
+       (set-marker pos nil)))
+
+    ;; undo deactivates mark unless undoing-in-region
+    (setq deactivate-mark (not undo-in-region))))
+
+
+
+(defun undo-tree-redo (&optional arg)
+  "Redo changes. A numeric ARG serves as a repeat count.
+
+In Transient Mark mode when the mark is active, only redo changes
+within the current region. Similarly, when not in Transient Mark
+mode, just \\[universal-argument] as an argument limits redo to
+changes within the current region."
+  (interactive "*P")
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t)
+    (user-error "No undo information in this buffer"))
+  (undo-tree-redo-1 arg)
+  ;; inform user if at branch point
+  (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))
+
+
+(defun undo-tree-redo-1 (&optional arg preserve-undo preserve-timestamps)
+  ;; Internal redo function. An active mark in `transient-mark-mode', or
+  ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-UNDO
+  ;; causes the existing redo record to be preserved, rather than replacing it
+  ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS
+  ;; disables updating of timestamps in visited undo-tree nodes. (This latter
+  ;; should *only* be used when temporarily visiting another undo state and
+  ;; immediately returning to the original state afterwards. Otherwise, it
+  ;; could cause history-discarding errors.)
+  (let ((undo-in-progress t)
+       (redo-in-region (and undo-tree-enable-undo-in-region
+                            (or (region-active-p)
+                                (and arg (not (numberp arg))))))
+       pos current)
+    ;; transfer entries accumulated in `buffer-undo-list' to
+    ;; `buffer-undo-tree'
+    (undo-list-transfer-to-tree)
+
+    (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
+      ;; check if at bottom of undo tree
+      (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree)))
+       (user-error "No further redo information"))
+
+      ;; if region is active, or a non-numeric prefix argument was supplied,
+      ;; try to pull out a new branch of changes affecting the region
+      (when (and redo-in-region
+                (not (undo-tree-pull-redo-in-region-branch
+                      (region-beginning) (region-end))))
+       (user-error "No further redo information for region"))
+
+      ;; get next node (but DON'T advance current node in tree yet, in case
+      ;; redoing fails)
+      (setq current (undo-tree-current buffer-undo-tree)
+           current (nth (undo-tree-node-branch current)
+                        (undo-tree-node-next current)))
+      ;; remove any GC'd elements from node's redo list
+      (decf (undo-tree-size buffer-undo-tree)
+           (undo-list-byte-size (undo-tree-node-redo current)))
+      (setf (undo-tree-node-redo current)
+           (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
+      (incf (undo-tree-size buffer-undo-tree)
+           (undo-list-byte-size (undo-tree-node-redo current)))
+      ;; redo one record from undo tree
+      (when redo-in-region
+       (setq pos (set-marker (make-marker) (point)))
+       (set-marker-insertion-type pos t))
+      (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current)))
+      (undo-boundary)
+      ;; advance current node in tree
+      (setf (undo-tree-current buffer-undo-tree) current)
+
+      ;; if preserving old undo record, discard new undo entries that
+      ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
+      ;; elements from node's redo list
+      (if preserve-undo
+         (progn
+           (undo-list-pop-changeset)
+           (decf (undo-tree-size buffer-undo-tree)
+                 (undo-list-byte-size (undo-tree-node-undo current)))
+           (setf (undo-tree-node-undo current)
+                 (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
+           (incf (undo-tree-size buffer-undo-tree)
+                 (undo-list-byte-size (undo-tree-node-undo current))))
+       ;; otherwise, record undo entries that `primitive-undo' has added to
+       ;; `buffer-undo-list' in current node's undo record, replacing
+       ;; existing entry if one already exists
+       (decf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-undo current)))
+       (setf (undo-tree-node-undo current)
+             (undo-list-pop-changeset 'discard-pos))
+       (incf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-undo current))))
+
+      ;; update timestamp
+      (unless preserve-timestamps
+       (setf (undo-tree-node-timestamp current) (current-time)))
+
+      ;; if redoing-in-region, record current node, region and direction so we
+      ;; can tell if redo-in-region is repeated, and re-activate mark if in
+      ;; `transient-mark-mode'
+      (if (not redo-in-region)
+         (undo-tree-node-clear-region-data current)
+       (goto-char pos)
+       (setf (undo-tree-node-redo-beginning current) (region-beginning)
+             (undo-tree-node-redo-end current) (region-end))
+       (set-marker pos nil)))
+
+    ;; redo deactivates the mark unless redoing-in-region
+    (setq deactivate-mark (not redo-in-region))))
+
+
+
+(defun undo-tree-switch-branch (branch)
+  "Switch to a different BRANCH of the undo tree.
+This will affect which branch to descend when *redoing* changes
+using `undo-tree-redo'."
+  (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg))
+                         (and (not (eq buffer-undo-list t))
+                             (or (undo-list-transfer-to-tree) t)
+                             (let ((b (undo-tree-node-branch
+                                       (undo-tree-current
+                                        buffer-undo-tree))))
+                               (cond
+                                ;; switch to other branch if only 2
+                                ((= (undo-tree-num-branches) 2) (- 1 b))
+                                ;; prompt if more than 2
+                                ((> (undo-tree-num-branches) 2)
+                                 (read-number
+                                  (format "Branch (0-%d, on %d): "
+                                          (1- (undo-tree-num-branches)) b)))
+                                ))))))
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t)
+    (user-error "No undo information in this buffer"))
+  ;; sanity check branch number
+  (when (<= (undo-tree-num-branches) 1)
+    (user-error "Not at undo branch point"))
+  (when (or (< branch 0) (> branch (1- (undo-tree-num-branches))))
+    (user-error "Invalid branch number"))
+  ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+  (undo-list-transfer-to-tree)
+  ;; switch branch
+  (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
+       branch)
+  (message "Switched to branch %d" branch))
+
+
+(defun undo-tree-set (node &optional preserve-timestamps)
+  ;; Set buffer to state corresponding to NODE. Returns intersection point
+  ;; between path back from current node and path back from selected NODE.
+  ;; Non-nil PRESERVE-TIMESTAMPS disables updating of timestamps in visited
+  ;; undo-tree nodes. (This should *only* be used when temporarily visiting
+  ;; another undo state and immediately returning to the original state
+  ;; afterwards. Otherwise, it could cause history-discarding errors.)
+  (let ((path (make-hash-table :test 'eq))
+        (n node))
+    (puthash (undo-tree-root buffer-undo-tree) t path)
+    ;; build list of nodes leading back from selected node to root, updating
+    ;; branches as we go to point down to selected node
+    (while (progn
+             (puthash n t path)
+             (when (undo-tree-node-previous n)
+               (setf (undo-tree-node-branch (undo-tree-node-previous n))
+                     (undo-tree-position
+                      n (undo-tree-node-next (undo-tree-node-previous n))))
+               (setq n (undo-tree-node-previous n)))))
+    ;; work backwards from current node until we intersect path back from
+    ;; selected node
+    (setq n (undo-tree-current buffer-undo-tree))
+    (while (not (gethash n path))
+      (setq n (undo-tree-node-previous n)))
+    ;; ascend tree until intersection node
+    (while (not (eq (undo-tree-current buffer-undo-tree) n))
+      (undo-tree-undo-1 nil nil preserve-timestamps))
+    ;; descend tree until selected node
+    (while (not (eq (undo-tree-current buffer-undo-tree) node))
+      (undo-tree-redo-1 nil nil preserve-timestamps))
+    n))  ; return intersection node
+
+
+
+(defun undo-tree-save-state-to-register (register)
+  "Store current undo-tree state to REGISTER.
+The saved state can be restored using
+`undo-tree-restore-state-from-register'.
+Argument is a character, naming the register."
+  (interactive "cUndo-tree state to register: ")
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t)
+    (user-error "No undo information in this buffer"))
+  ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+  (undo-list-transfer-to-tree)
+  ;; save current node to REGISTER
+  (set-register
+   register (registerv-make
+            (undo-tree-make-register-data
+             (current-buffer) (undo-tree-current buffer-undo-tree))
+            :print-func 'undo-tree-register-data-print-func))
+  ;; record REGISTER in current node, for visualizer
+  (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree))
+       register))
+
+
+
+(defun undo-tree-restore-state-from-register (register)
+  "Restore undo-tree state from REGISTER.
+The state must be saved using `undo-tree-save-state-to-register'.
+Argument is a character, naming the register."
+  (interactive "*cRestore undo-tree state from register: ")
+  ;; throw error if undo is disabled in buffer, or if register doesn't contain
+  ;; an undo-tree node
+  (let ((data (registerv-data (get-register register))))
+    (cond
+     ((eq buffer-undo-list t)
+      (user-error "No undo information in this buffer"))
+     ((not (undo-tree-register-data-p data))
+      (user-error "Register doesn't contain undo-tree state"))
+     ((not (eq (current-buffer) (undo-tree-register-data-buffer data)))
+      (user-error "Register contains undo-tree state for a different buffer")))
+    ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+    (undo-list-transfer-to-tree)
+    ;; restore buffer state corresponding to saved node
+    (undo-tree-set (undo-tree-register-data-node data))))
+
+
+
+\f
+;;; =====================================================================
+;;;                    Persistent storage commands
+
+(defun undo-tree-make-history-save-file-name (file)
+  "Create the undo history file name for FILE.
+Normally this is the file's name with `.' prepended and
+`~undo-tree~' appended.
+
+A match for FILE is sought in `undo-tree-history-directory-alist';
+see the documentation of that variable.  If the directory for the
+backup doesn't exist, it is created."
+  (let* ((backup-directory-alist undo-tree-history-directory-alist)
+        (name (make-backup-file-name-1 file)))
+    (concat (file-name-directory name) "." (file-name-nondirectory name)
+           "~undo-tree~")))
+
+
+(defun undo-tree-save-history (&optional filename overwrite)
+  "Store undo-tree history to file.
+
+If optional argument FILENAME is omitted, default save file is
+\".<buffer-file-name>.~undo-tree\" if buffer is visiting a file.
+Otherwise, prompt for one.
+
+If OVERWRITE is non-nil, any existing file will be overwritten
+without asking for confirmation."
+  (interactive)
+  (when (eq buffer-undo-list t)
+    (user-error "No undo information in this buffer"))
+  (undo-list-transfer-to-tree)
+  (when (and buffer-undo-tree (not (eq buffer-undo-tree t)))
+    (condition-case nil
+       (undo-tree-kill-visualizer)
+      (error (undo-tree-clear-visualizer-data buffer-undo-tree)))
+    (let ((buff (current-buffer))
+         tree)
+      ;; get filename
+      (unless filename
+       (setq filename
+             (if buffer-file-name
+                 (undo-tree-make-history-save-file-name buffer-file-name)
+               (expand-file-name (read-file-name "File to save in: ") nil))))
+      (when (or (not (file-exists-p filename))
+               overwrite
+               (yes-or-no-p (format "Overwrite \"%s\"? " filename)))
+       (unwind-protect
+           (progn
+             ;; transform undo-tree into non-circular structure, and make
+             ;; temporary copy
+             (undo-tree-decircle buffer-undo-tree)
+             (setq tree (copy-undo-tree buffer-undo-tree))
+             ;; discard undo-tree object pool before saving
+             (setf (undo-tree-object-pool tree) nil)
+             ;; print undo-tree to file
+             ;; NOTE: We use `with-temp-buffer' instead of `with-temp-file'
+             ;;       to allow `auto-compression-mode' to take effect, in
+             ;;       case user has overridden or advised the default
+             ;;       `undo-tree-make-history-save-file-name' to add a
+             ;;       compressed file extension.
+             (with-auto-compression-mode
+               (with-temp-buffer
+                 (prin1 (sha1 buff) (current-buffer))
+                 (terpri (current-buffer))
+                 (let ((print-circle t)) (prin1 tree (current-buffer)))
+                 (write-region nil nil filename))))
+         ;; restore circular undo-tree data structure
+         (undo-tree-recircle buffer-undo-tree))
+       ))))
+
+
+
+(defun undo-tree-load-history (&optional filename noerror)
+  "Load undo-tree history from file.
+
+If optional argument FILENAME is null, default load file is
+\".<buffer-file-name>.~undo-tree\" if buffer is visiting a file.
+Otherwise, prompt for one.
+
+If optional argument NOERROR is non-nil, return nil instead of
+signaling an error if file is not found."
+  (interactive)
+  ;; get filename
+  (unless filename
+    (setq filename
+         (if buffer-file-name
+             (undo-tree-make-history-save-file-name buffer-file-name)
+           (expand-file-name (read-file-name "File to load from: ") nil))))
+
+  ;; attempt to read undo-tree from FILENAME
+  (catch 'load-error
+    (unless (file-exists-p filename)
+      (if noerror
+         (throw 'load-error nil)
+       (error "File \"%s\" does not exist; could not load undo-tree history"
+              filename)))
+    (let (buff hash tree)
+      (setq buff (current-buffer))
+      (with-auto-compression-mode
+       (with-temp-buffer
+         (insert-file-contents filename)
+         (goto-char (point-min))
+         (condition-case nil
+             (setq hash (read (current-buffer)))
+           (error
+            (kill-buffer nil)
+            (funcall (if noerror 'message 'error)
+                     "Error reading undo-tree history from \"%s\"" filename)
+            (throw 'load-error nil)))
+         (unless (string= (sha1 buff) hash)
+           (kill-buffer nil)
+           (funcall (if noerror 'message 'error)
+                    "Buffer has been modified; could not load undo-tree history")
+           (throw 'load-error nil))
+         (condition-case nil
+             (setq tree (read (current-buffer)))
+           (error
+            (kill-buffer nil)
+            (funcall (if noerror 'message 'error)
+                     "Error reading undo-tree history from \"%s\"" filename)
+            (throw 'load-error nil)))
+         (kill-buffer nil)))
+      ;; initialise empty undo-tree object pool
+      (setf (undo-tree-object-pool tree)
+           (make-hash-table :test 'eq :weakness 'value))
+      ;; restore circular undo-tree data structure
+      (undo-tree-recircle tree)
+      (setq buffer-undo-tree tree))))
+
+
+
+;; Versions of save/load functions for use in hooks
+(defun undo-tree-save-history-hook ()
+  (when (and undo-tree-mode undo-tree-auto-save-history
+            (not (eq buffer-undo-list t)))
+    (undo-tree-save-history nil t) nil))
+
+(defun undo-tree-load-history-hook ()
+  (when (and undo-tree-mode undo-tree-auto-save-history
+            (not (eq buffer-undo-list t)))
+    (undo-tree-load-history nil t)))
+
+
+
+\f
+;;; =====================================================================
+;;;                    Visualizer drawing functions
+
+(defun undo-tree-visualize ()
+  "Visualize the current buffer's undo tree."
+  (interactive "*")
+  (deactivate-mark)
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t)
+    (user-error "No undo information in this buffer"))
+  ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+  (undo-list-transfer-to-tree)
+  ;; add hook to kill visualizer buffer if original buffer is changed
+  (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t)
+  ;; prepare *undo-tree* buffer, then draw tree in it
+  (let ((undo-tree buffer-undo-tree)
+        (buff (current-buffer))
+       (display-buffer-mark-dedicated 'soft))
+    (switch-to-buffer-other-window
+     (get-buffer-create undo-tree-visualizer-buffer-name))
+    (setq undo-tree-visualizer-parent-buffer buff)
+    (setq undo-tree-visualizer-parent-mtime
+         (and (buffer-file-name buff)
+              (nth 5 (file-attributes (buffer-file-name buff)))))
+    (setq buffer-undo-tree undo-tree)
+    (setq undo-tree-visualizer-initial-node (undo-tree-current undo-tree))
+    (setq undo-tree-visualizer-spacing
+         (undo-tree-visualizer-calculate-spacing))
+    (make-local-variable 'undo-tree-visualizer-timestamps)
+    (make-local-variable 'undo-tree-visualizer-diff)
+    (set (make-local-variable 'undo-tree-visualizer-lazy-drawing)
+        (or (eq undo-tree-visualizer-lazy-drawing t)
+            (and (numberp undo-tree-visualizer-lazy-drawing)
+                 (>= (undo-tree-count undo-tree)
+                     undo-tree-visualizer-lazy-drawing))))
+    (when undo-tree-visualizer-diff (undo-tree-visualizer-show-diff))
+    (undo-tree-visualizer-mode)
+    (let ((inhibit-read-only t)) (undo-tree-draw-tree undo-tree))))
+
+
+(defun undo-tree-kill-visualizer (&rest _dummy)
+  ;; Kill visualizer. Added to `before-change-functions' hook of original
+  ;; buffer when visualizer is invoked.
+  (unless undo-tree-inhibit-kill-visualizer
+    (unwind-protect
+       (with-current-buffer undo-tree-visualizer-buffer-name
+         (undo-tree-visualizer-quit)))))
+
+
+
+(defun undo-tree-draw-tree (undo-tree)
+  ;; Draw undo-tree in current buffer starting from NODE (or root if nil).
+  (let ((node (if undo-tree-visualizer-lazy-drawing
+                 (undo-tree-current undo-tree)
+               (undo-tree-root undo-tree))))
+    (erase-buffer)
+    (undo-tree-clear-visualizer-data undo-tree)
+    (undo-tree-compute-widths node)
+    ;; lazy drawing starts vertically centred and displaced horizontally to
+    ;; the left (window-width/4), since trees will typically grow right
+    (if undo-tree-visualizer-lazy-drawing
+       (progn
+         (undo-tree-move-down (/ (window-height) 2))
+         (undo-tree-move-forward (max 2 (/ (window-width) 4)))) ; left margin
+      ;; non-lazy drawing starts in centre at top of buffer
+      (undo-tree-move-down 1)  ; top margin
+      (undo-tree-move-forward
+       (max (/ (window-width) 2)
+           (+ (undo-tree-node-char-lwidth node)
+              ;; add space for left part of left-most time-stamp
+              (if undo-tree-visualizer-timestamps
+                  (/ (- undo-tree-visualizer-spacing 4) 2)
+                0)
+              2))))  ; left margin
+    ;; link starting node to its representation in visualizer
+    (setf (undo-tree-node-marker node) (make-marker))
+    (set-marker-insertion-type (undo-tree-node-marker node) nil)
+    (move-marker (undo-tree-node-marker node) (point))
+    ;; draw undo-tree
+    (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
+         node-list)
+      (if (not undo-tree-visualizer-lazy-drawing)
+         (undo-tree-extend-down node t)
+       (undo-tree-extend-down node)
+       (undo-tree-extend-up node)
+       (setq node-list undo-tree-visualizer-needs-extending-down
+             undo-tree-visualizer-needs-extending-down nil)
+       (while node-list (undo-tree-extend-down (pop node-list)))))
+    ;; highlight active branch
+    (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
+      (undo-tree-highlight-active-branch
+       (or undo-tree-visualizer-needs-extending-up
+          (undo-tree-root undo-tree))))
+    ;; highlight current node
+    (undo-tree-draw-node (undo-tree-current undo-tree) 'current)))
+
+
+(defun undo-tree-extend-down (node &optional bottom)
+  ;; Extend tree downwards starting from NODE and point. If BOTTOM is t,
+  ;; extend all the way down to the leaves. If BOTTOM is a node, extend down
+  ;; as far as that node. If BOTTOM is an integer, extend down as far as that
+  ;; line. Otherwise, only extend visible portion of tree. NODE is assumed to
+  ;; already have a node marker. Returns non-nil if anything was actually
+  ;; extended.
+  (let ((extended nil)
+       (cur-stack (list node))
+       next-stack)
+    ;; don't bother extending if BOTTOM specifies an already-drawn node
+    (unless (and (undo-tree-node-p bottom) (undo-tree-node-marker bottom))
+      ;; draw nodes layer by layer
+      (while (or cur-stack
+                (prog1 (setq cur-stack next-stack)
+                  (setq next-stack nil)))
+       (setq node (pop cur-stack))
+       ;; if node is within range being drawn...
+       (if (or (eq bottom t)
+               (and (undo-tree-node-p bottom)
+                    (not (eq (undo-tree-node-previous node) bottom)))
+               (and (integerp bottom)
+                    (>= bottom (line-number-at-pos
+                                (undo-tree-node-marker node))))
+               (and (null bottom)
+                    (pos-visible-in-window-p (undo-tree-node-marker node)
+                                             nil t)))
+           ;; ...draw one layer of node's subtree (if not already drawn)
+           (progn
+             (unless (and (undo-tree-node-next node)
+                          (undo-tree-node-marker
+                           (nth (undo-tree-node-branch node)
+                                (undo-tree-node-next node))))
+               (goto-char (undo-tree-node-marker node))
+               (undo-tree-draw-subtree node)
+               (setq extended t))
+             (setq next-stack
+                   (append (undo-tree-node-next node) next-stack)))
+         ;; ...otherwise, postpone drawing until later
+         (push node undo-tree-visualizer-needs-extending-down))))
+    extended))
+
+
+(defun undo-tree-extend-up (node &optional top)
+  ;; Extend tree upwards starting from NODE. If TOP is t, extend all the way
+  ;; to root. If TOP is a node, extend up as far as that node. If TOP is an
+  ;; integer, extend up as far as that line. Otherwise, only extend visible
+  ;; portion of tree. NODE is assumed to already have a node marker. Returns
+  ;; non-nil if anything was actually extended.
+  (let ((extended nil) parent n)
+    ;; don't bother extending if TOP specifies an already-drawn node
+    (unless (and (undo-tree-node-p top) (undo-tree-node-marker top))
+      (while node
+       (setq parent (undo-tree-node-previous node))
+       ;; if we haven't reached root...
+       (if parent
+           ;; ...and node is within range being drawn...
+           (if (or (eq top t)
+                   (and (undo-tree-node-p top) (not (eq node top)))
+                   (and (integerp top)
+                        (< top (line-number-at-pos
+                                (undo-tree-node-marker node))))
+                   (and (null top)
+                        ;; NOTE: check point in case window-start is outdated
+                        (< (min (line-number-at-pos (point))
+                                (line-number-at-pos (window-start)))
+                           (line-number-at-pos
+                            (undo-tree-node-marker node)))))
+               ;; ...and it hasn't already been drawn
+               (when (not (undo-tree-node-marker parent))
+                 ;; link parent node to its representation in visualizer
+                 (undo-tree-compute-widths parent)
+                 (undo-tree-move-to-parent node)
+                 (setf (undo-tree-node-marker parent) (make-marker))
+                 (set-marker-insertion-type
+                  (undo-tree-node-marker parent) nil)
+                 (move-marker (undo-tree-node-marker parent) (point))
+                 ;; draw subtree beneath parent
+                 (setq undo-tree-visualizer-needs-extending-down
+                       (nconc (delq node (undo-tree-draw-subtree parent))
+                              undo-tree-visualizer-needs-extending-down))
+                 (setq extended t))
+             ;; ...otherwise, postpone drawing for later and exit
+             (setq undo-tree-visualizer-needs-extending-up (when parent node)
+                   parent nil))
+
+         ;; if we've reached root, stop extending and add top margin
+         (setq undo-tree-visualizer-needs-extending-up nil)
+         (goto-char (undo-tree-node-marker node))
+         (undo-tree-move-up 1)  ; top margin
+         (delete-region (point-min) (line-beginning-position)))
+       ;; next iteration
+       (setq node parent)))
+    extended))
+
+
+(defun undo-tree-expand-down (from &optional to)
+  ;; Expand tree downwards. FROM is the node to start expanding from. Stop
+  ;; expanding at TO if specified. Otherwise, just expand visible portion of
+  ;; tree and highlight active branch from FROM.
+  (when undo-tree-visualizer-needs-extending-down
+    (let ((inhibit-read-only t)
+         node-list extended)
+      ;; extend down as far as TO node
+      (when to
+       (setq extended (undo-tree-extend-down from to))
+       (goto-char (undo-tree-node-marker to))
+       (redisplay t))  ; force redisplay to scroll buffer if necessary
+      ;; extend visible portion of tree downwards
+      (setq node-list undo-tree-visualizer-needs-extending-down
+           undo-tree-visualizer-needs-extending-down nil)
+      (when node-list
+       (dolist (n node-list)
+         (when (undo-tree-extend-down n) (setq extended t)))
+       ;; highlight active branch in newly-extended-down portion, if any
+       (when extended
+         (let ((undo-tree-insert-face
+                'undo-tree-visualizer-active-branch-face))
+           (undo-tree-highlight-active-branch from)))))))
+
+
+(defun undo-tree-expand-up (from &optional to)
+  ;; Expand tree upwards. FROM is the node to start expanding from, TO is the
+  ;; node to stop expanding at. If TO node isn't specified, just expand visible
+  ;; portion of tree and highlight active branch down to FROM.
+  (when undo-tree-visualizer-needs-extending-up
+    (let ((inhibit-read-only t)
+         extended node-list)
+      ;; extend up as far as TO node
+      (when to
+       (setq extended (undo-tree-extend-up from to))
+       (goto-char (undo-tree-node-marker to))
+       ;; simulate auto-scrolling if close to top of buffer
+       (when (<= (line-number-at-pos (point)) scroll-margin)
+         (undo-tree-move-up (if (= scroll-conservatively 0)
+                                (/ (window-height) 2) 3))
+         (when (undo-tree-extend-up to) (setq extended t))
+         (goto-char (undo-tree-node-marker to))
+         (unless (= scroll-conservatively 0) (recenter scroll-margin))))
+      ;; extend visible portion of tree upwards
+      (and undo-tree-visualizer-needs-extending-up
+          (undo-tree-extend-up undo-tree-visualizer-needs-extending-up)
+          (setq extended t))
+      ;; extend visible portion of tree downwards
+      (setq node-list undo-tree-visualizer-needs-extending-down
+           undo-tree-visualizer-needs-extending-down nil)
+      (dolist (n node-list) (undo-tree-extend-down n))
+      ;; highlight active branch in newly-extended-up portion, if any
+      (when extended
+       (let ((undo-tree-insert-face
+              'undo-tree-visualizer-active-branch-face))
+         (undo-tree-highlight-active-branch
+          (or undo-tree-visualizer-needs-extending-up
+              (undo-tree-root buffer-undo-tree))
+          from))))))
+
+
+
+(defun undo-tree-highlight-active-branch (node &optional end)
+  ;; Draw highlighted active branch below NODE in current buffer. Stop
+  ;; highlighting at END node if specified.
+  (let ((stack (list node)))
+    ;; draw active branch
+    (while stack
+      (setq node (pop stack))
+      (unless (or (eq node end)
+                 (memq node undo-tree-visualizer-needs-extending-down))
+       (goto-char (undo-tree-node-marker node))
+       (setq node (undo-tree-draw-subtree node 'active)
+             stack (nconc stack node))))))
+
+
+(defun undo-tree-draw-node (node &optional current)
+  ;; Draw symbol representing NODE in visualizer. If CURRENT is non-nil, node
+  ;; is current node.
+  (goto-char (undo-tree-node-marker node))
+  (when undo-tree-visualizer-timestamps
+    (undo-tree-move-backward (/ undo-tree-visualizer-spacing 2)))
+
+  (let* ((undo-tree-insert-face (and undo-tree-insert-face
+                                    (or (and (consp undo-tree-insert-face)
+                                             undo-tree-insert-face)
+                                        (list undo-tree-insert-face))))
+        (register (undo-tree-node-register node))
+        (unmodified (if undo-tree-visualizer-parent-mtime
+                        (undo-tree-node-unmodified-p
+                         node undo-tree-visualizer-parent-mtime)
+                      (undo-tree-node-unmodified-p node)))
+       node-string)
+    ;; check node's register (if any) still stores appropriate undo-tree state
+    (unless (and register
+                (undo-tree-register-data-p
+                 (registerv-data (get-register register)))
+                (eq node (undo-tree-register-data-node
+                          (registerv-data (get-register register)))))
+      (setq register nil))
+    ;; represent node by different symbols, depending on whether it's the
+    ;; current node, is saved in a register, or corresponds to an unmodified
+    ;; buffer
+    (setq node-string
+           (cond
+            (undo-tree-visualizer-timestamps
+               (undo-tree-timestamp-to-string
+                (undo-tree-node-timestamp node)
+                undo-tree-visualizer-relative-timestamps
+                current register))
+            (register (char-to-string register))
+            (unmodified "s")
+            (current "x")
+            (t "o"))
+         undo-tree-insert-face
+           (nconc
+            (cond
+             (current    '(undo-tree-visualizer-current-face))
+             (unmodified '(undo-tree-visualizer-unmodified-face))
+             (register   '(undo-tree-visualizer-register-face)))
+            undo-tree-insert-face))
+    ;; draw node and link it to its representation in visualizer
+    (undo-tree-insert node-string)
+    (undo-tree-move-backward (if undo-tree-visualizer-timestamps
+                                (1+ (/ undo-tree-visualizer-spacing 2))
+                              1))
+    (move-marker (undo-tree-node-marker node) (point))
+    (put-text-property (point) (1+ (point)) 'undo-tree-node node)))
+
+
+(defun undo-tree-draw-subtree (node &optional active-branch)
+  ;; Draw subtree rooted at NODE. The subtree will start from point.
+  ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE. Returns
+  ;; list of nodes below NODE.
+  (let ((num-children (length (undo-tree-node-next node)))
+        node-list pos trunk-pos n)
+    ;; draw node itself
+    (undo-tree-draw-node node)
+
+    (cond
+     ;; if we're at a leaf node, we're done
+     ((= num-children 0))
+
+     ;; if node has only one child, draw it (not strictly necessary to deal
+     ;; with this case separately, but as it's by far the most common case
+     ;; this makes the code clearer and more efficient)
+     ((= num-children 1)
+      (undo-tree-move-down 1)
+      (undo-tree-insert ?|)
+      (undo-tree-move-backward 1)
+      (undo-tree-move-down 1)
+      (undo-tree-insert ?|)
+      (undo-tree-move-backward 1)
+      (undo-tree-move-down 1)
+      (setq n (car (undo-tree-node-next node)))
+      ;; link next node to its representation in visualizer
+      (unless (markerp (undo-tree-node-marker n))
+        (setf (undo-tree-node-marker n) (make-marker))
+        (set-marker-insertion-type (undo-tree-node-marker n) nil))
+      (move-marker (undo-tree-node-marker n) (point))
+      ;; add next node to list of nodes to draw next
+      (push n node-list))
+
+     ;; if node has multiple children, draw branches
+     (t
+      (undo-tree-move-down 1)
+      (undo-tree-insert ?|)
+      (undo-tree-move-backward 1)
+      (move-marker (setq trunk-pos (make-marker)) (point))
+      ;; left subtrees
+      (undo-tree-move-backward
+       (- (undo-tree-node-char-lwidth node)
+          (undo-tree-node-char-lwidth
+           (car (undo-tree-node-next node)))))
+      (move-marker (setq pos (make-marker)) (point))
+      (setq n (cons nil (undo-tree-node-next node)))
+      (dotimes (i (/ num-children 2))
+        (setq n (cdr n))
+        (when (or (null active-branch)
+                  (eq (car n)
+                      (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node))))
+          (undo-tree-move-forward 2)
+          (undo-tree-insert ?_ (- trunk-pos pos 2))
+          (goto-char pos)
+          (undo-tree-move-forward 1)
+          (undo-tree-move-down 1)
+          (undo-tree-insert ?/)
+          (undo-tree-move-backward 2)
+          (undo-tree-move-down 1)
+          ;; link node to its representation in visualizer
+          (unless (markerp (undo-tree-node-marker (car n)))
+            (setf (undo-tree-node-marker (car n)) (make-marker))
+            (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
+          (move-marker (undo-tree-node-marker (car n)) (point))
+          ;; add node to list of nodes to draw next
+          (push (car n) node-list))
+        (goto-char pos)
+        (undo-tree-move-forward
+         (+ (undo-tree-node-char-rwidth (car n))
+            (undo-tree-node-char-lwidth (cadr n))
+            undo-tree-visualizer-spacing 1))
+        (move-marker pos (point)))
+      ;; middle subtree (only when number of children is odd)
+      (when (= (mod num-children 2) 1)
+        (setq n (cdr n))
+        (when (or (null active-branch)
+                  (eq (car n)
+                      (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node))))
+          (undo-tree-move-down 1)
+          (undo-tree-insert ?|)
+          (undo-tree-move-backward 1)
+          (undo-tree-move-down 1)
+          ;; link node to its representation in visualizer
+          (unless (markerp (undo-tree-node-marker (car n)))
+            (setf (undo-tree-node-marker (car n)) (make-marker))
+            (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
+          (move-marker (undo-tree-node-marker (car n)) (point))
+          ;; add node to list of nodes to draw next
+          (push (car n) node-list))
+        (goto-char pos)
+        (undo-tree-move-forward
+         (+ (undo-tree-node-char-rwidth (car n))
+            (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
+            undo-tree-visualizer-spacing 1))
+        (move-marker pos (point)))
+      ;; right subtrees
+      (move-marker trunk-pos (1+ trunk-pos))
+      (dotimes (i (/ num-children 2))
+        (setq n (cdr n))
+        (when (or (null active-branch)
+                  (eq (car n)
+                      (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node))))
+          (goto-char trunk-pos)
+          (undo-tree-insert ?_ (- pos trunk-pos 1))
+          (goto-char pos)
+          (undo-tree-move-backward 1)
+          (undo-tree-move-down 1)
+          (undo-tree-insert ?\\)
+          (undo-tree-move-down 1)
+          ;; link node to its representation in visualizer
+          (unless (markerp (undo-tree-node-marker (car n)))
+            (setf (undo-tree-node-marker (car n)) (make-marker))
+            (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
+          (move-marker (undo-tree-node-marker (car n)) (point))
+          ;; add node to list of nodes to draw next
+          (push (car n) node-list))
+        (when (cdr n)
+          (goto-char pos)
+          (undo-tree-move-forward
+           (+ (undo-tree-node-char-rwidth (car n))
+              (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
+              undo-tree-visualizer-spacing 1))
+          (move-marker pos (point))))
+      ))
+    ;; return list of nodes to draw next
+    (nreverse node-list)))
+
+
+(defun undo-tree-node-char-lwidth (node)
+  ;; Return left-width of NODE measured in characters.
+  (if (= (length (undo-tree-node-next node)) 0) 0
+    (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node))
+       (if (= (undo-tree-node-cwidth node) 0)
+           (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
+
+
+(defun undo-tree-node-char-rwidth (node)
+  ;; Return right-width of NODE measured in characters.
+  (if (= (length (undo-tree-node-next node)) 0) 0
+    (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node))
+       (if (= (undo-tree-node-cwidth node) 0)
+           (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
+
+
+(defun undo-tree-insert (str &optional arg)
+  ;; Insert character or string STR ARG times, overwriting, and using
+  ;; `undo-tree-insert-face'.
+  (unless arg (setq arg 1))
+  (when (characterp str)
+    (setq str (make-string arg str))
+    (setq arg 1))
+  (dotimes (i arg) (insert str))
+  (setq arg (* arg (length str)))
+  (undo-tree-move-forward arg)
+  ;; make sure mark isn't active, otherwise `backward-delete-char' might
+  ;; delete region instead of single char if transient-mark-mode is enabled
+  (setq mark-active nil)
+  (backward-delete-char arg)
+  (when undo-tree-insert-face
+    (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face)))
+
+
+(defun undo-tree-move-down (&optional arg)
+  ;; Move down, extending buffer if necessary.
+  (let ((row (line-number-at-pos))
+        (col (current-column))
+        line)
+    (unless arg (setq arg 1))
+    (forward-line arg)
+    (setq line (line-number-at-pos))
+    ;; if buffer doesn't have enough lines, add some
+    (when (/= line (+ row arg))
+      (cond
+       ((< arg 0)
+       (insert (make-string (- line row arg) ?\n))
+       (forward-line (+ arg (- row line))))
+       (t (insert (make-string (- arg (- line row)) ?\n)))))
+    (undo-tree-move-forward col)))
+
+
+(defun undo-tree-move-up (&optional arg)
+  ;; Move up, extending buffer if necessary.
+  (unless arg (setq arg 1))
+  (undo-tree-move-down (- arg)))
+
+
+(defun undo-tree-move-forward (&optional arg)
+  ;; Move forward, extending buffer if necessary.
+  (unless arg (setq arg 1))
+  (let (n)
+    (cond
+     ((>= arg 0)
+      (setq n (- (line-end-position) (point)))
+      (if (> n arg)
+         (forward-char arg)
+       (end-of-line)
+       (insert (make-string (- arg n) ? ))))
+     ((< arg 0)
+      (setq arg (- arg))
+      (setq n (- (point) (line-beginning-position)))
+      (when (< (- n 2) arg)  ; -2 to create left-margin
+       ;; no space left - shift entire buffer contents right!
+       (let ((pos (move-marker (make-marker) (point))))
+         (set-marker-insertion-type pos t)
+         (goto-char (point-min))
+         (while (not (eobp))
+           (insert-before-markers (make-string (- arg -2 n) ? ))
+           (forward-line 1))
+         (goto-char pos)))
+      (backward-char arg)))))
+
+
+(defun undo-tree-move-backward (&optional arg)
+  ;; Move backward, extending buffer if necessary.
+  (unless arg (setq arg 1))
+  (undo-tree-move-forward (- arg)))
+
+
+(defun undo-tree-move-to-parent (node)
+  ;; Move to position of parent of NODE, extending buffer if necessary.
+  (let* ((parent (undo-tree-node-previous node))
+        (n (undo-tree-node-next parent))
+        (l (length n)) p)
+    (goto-char (undo-tree-node-marker node))
+    (unless (= l 1)
+      ;; move horizontally
+      (setq p (undo-tree-position node n))
+      (cond
+       ;; node in centre subtree: no horizontal movement
+       ((and (= (mod l 2) 1) (= p (/ l 2))))
+       ;; node in left subtree: move right
+       ((< p (/ l 2))
+       (setq n (nthcdr p n))
+       (undo-tree-move-forward
+        (+ (undo-tree-node-char-rwidth (car n))
+           (/ undo-tree-visualizer-spacing 2) 1))
+       (dotimes (i (- (/ l 2) p 1))
+         (setq n (cdr n))
+         (undo-tree-move-forward
+          (+ (undo-tree-node-char-lwidth (car n))
+             (undo-tree-node-char-rwidth (car n))
+             undo-tree-visualizer-spacing 1)))
+       (when (= (mod l 2) 1)
+         (setq n (cdr n))
+         (undo-tree-move-forward
+          (+ (undo-tree-node-char-lwidth (car n))
+             (/ undo-tree-visualizer-spacing 2) 1))))
+       (t ;; node in right subtree: move left
+       (setq n (nthcdr (/ l 2) n))
+       (when (= (mod l 2) 1)
+         (undo-tree-move-backward
+          (+ (undo-tree-node-char-rwidth (car n))
+             (/ undo-tree-visualizer-spacing 2) 1))
+         (setq n (cdr n)))
+       (dotimes (i (- p (/ l 2) (mod l 2)))
+         (undo-tree-move-backward
+          (+ (undo-tree-node-char-lwidth (car n))
+             (undo-tree-node-char-rwidth (car n))
+             undo-tree-visualizer-spacing 1))
+         (setq n (cdr n)))
+       (undo-tree-move-backward
+        (+ (undo-tree-node-char-lwidth (car n))
+           (/ undo-tree-visualizer-spacing 2) 1)))))
+    ;; move vertically
+    (undo-tree-move-up 3)))
+
+
+(defun undo-tree-timestamp-to-string
+  (timestamp &optional relative current register)
+  ;; Convert TIMESTAMP to string (either absolute or RELATVE time), indicating
+  ;; if it's the CURRENT node and/or has an associated REGISTER.
+  (if relative
+      ;; relative time
+      (let ((time (floor (float-time
+                         (subtract-time (current-time) timestamp))))
+           n)
+       (setq time
+             ;; years
+             (if (> (setq n (/ time 315360000)) 0)
+                 (if (> n 999) "-ages" (format "-%dy" n))
+               (setq time (% time 315360000))
+               ;; days
+               (if (> (setq n (/ time 86400)) 0)
+                   (format "-%dd" n)
+                 (setq time (% time 86400))
+                 ;; hours
+                 (if (> (setq n (/ time 3600)) 0)
+                     (format "-%dh" n)
+                   (setq time (% time 3600))
+                   ;; mins
+                   (if (> (setq n (/ time 60)) 0)
+                       (format "-%dm" n)
+                     ;; secs
+                     (format "-%ds" (% time 60)))))))
+       (setq time (concat
+                   (if current "*" " ")
+                   time
+                   (if register (concat "[" (char-to-string register) "]")
+                     "   ")))
+       (setq n (length time))
+       (if (< n 9)
+           (concat (make-string (- 9 n) ? ) time)
+         time))
+    ;; absolute time
+    (concat (if current "*" " ")
+           (format-time-string "%H:%M:%S" timestamp)
+           (if register
+               (concat "[" (char-to-string register) "]")
+             "   "))))
+
+
+
+\f
+;;; =====================================================================
+;;;                        Visualizer commands
+
+(defun undo-tree-visualizer-mode ()
+  "Major mode used in undo-tree visualizer.
+
+The undo-tree visualizer can only be invoked from a buffer in
+which `undo-tree-mode' is enabled. The visualizer displays the
+undo history tree graphically, and allows you to browse around
+the undo history, undoing or redoing the corresponding changes in
+the parent buffer.
+
+Within the undo-tree visualizer, the following keys are available:
+
+  \\{undo-tree-visualizer-map}"
+  (interactive)
+  (setq major-mode 'undo-tree-visualizer-mode)
+  (setq mode-name "undo-tree-visualizer-mode")
+  (use-local-map undo-tree-visualizer-map)
+  (setq truncate-lines t)
+  (setq cursor-type nil)
+  (setq buffer-read-only t)
+  (setq undo-tree-visualizer-selected-node nil)
+  (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))
+
+
+
+(defun undo-tree-visualize-undo (&optional arg)
+  "Undo changes. A numeric ARG serves as a repeat count."
+  (interactive "p")
+  (let ((old (undo-tree-current buffer-undo-tree))
+       current)
+    ;; unhighlight old current node
+    (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)
+         (inhibit-read-only t))
+      (undo-tree-draw-node old))
+    ;; undo in parent buffer
+    (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
+    (deactivate-mark)
+    (unwind-protect
+       (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-undo-1 arg))
+      (setq current (undo-tree-current buffer-undo-tree))
+      (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
+      ;; when using lazy drawing, extend tree upwards as required
+      (when undo-tree-visualizer-lazy-drawing
+       (undo-tree-expand-up old current))
+      ;; highlight new current node
+      (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current))
+      ;; update diff display, if any
+      (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))))
+
+
+(defun undo-tree-visualize-redo (&optional arg)
+  "Redo changes. A numeric ARG serves as a repeat count."
+  (interactive "p")
+  (let ((old (undo-tree-current buffer-undo-tree))
+       current)
+    ;; unhighlight old current node
+    (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)
+         (inhibit-read-only t))
+      (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
+    ;; redo in parent buffer
+    (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
+    (deactivate-mark)
+    (unwind-protect
+       (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-redo-1 arg))
+      (setq current (undo-tree-current buffer-undo-tree))
+      (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
+      ;; when using lazy drawing, extend tree downwards as required
+      (when undo-tree-visualizer-lazy-drawing
+       (undo-tree-expand-down old current))
+      ;; highlight new current node
+      (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current))
+      ;; update diff display, if any
+      (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))))
+
+
+(defun undo-tree-visualize-switch-branch-right (arg)
+  "Switch to next branch of the undo tree.
+This will affect which branch to descend when *redoing* changes
+using `undo-tree-redo' or `undo-tree-visualizer-redo'."
+  (interactive "p")
+  ;; un-highlight old active branch below current node
+  (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
+       (inhibit-read-only t))
+    (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
+  ;; increment branch
+  (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree))))
+  (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
+        (cond
+         ((>= (+ branch arg) (undo-tree-num-branches))
+          (1- (undo-tree-num-branches)))
+         ((<= (+ branch arg) 0) 0)
+         (t (+ branch arg))))
+  (let ((inhibit-read-only t))
+    ;; highlight new active branch below current node
+    (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
+    (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
+      (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
+    ;; re-highlight current node
+    (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current))))
+
+
+(defun undo-tree-visualize-switch-branch-left (arg)
+  "Switch to previous branch of the undo tree.
+This will affect which branch to descend when *redoing* changes
+using `undo-tree-redo' or `undo-tree-visualizer-redo'."
+  (interactive "p")
+  (undo-tree-visualize-switch-branch-right (- arg)))
+
+
+(defun undo-tree-visualizer-quit ()
+  "Quit the undo-tree visualizer."
+  (interactive)
+  (undo-tree-clear-visualizer-data buffer-undo-tree)
+  ;; remove kill visualizer hook from parent buffer
+  (unwind-protect
+      (with-current-buffer undo-tree-visualizer-parent-buffer
+       (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t))
+    ;; kill diff buffer, if any
+    (when undo-tree-visualizer-diff (undo-tree-visualizer-hide-diff))
+    (let ((parent undo-tree-visualizer-parent-buffer)
+         window)
+      ;; kill visualizer buffer
+      (kill-buffer nil)
+      ;; switch back to parent buffer
+      (unwind-protect
+         (if (setq window (get-buffer-window parent))
+             (select-window window)
+           (switch-to-buffer parent))))))
+
+
+(defun undo-tree-visualizer-abort ()
+  "Quit the undo-tree visualizer and return buffer to original state."
+  (interactive)
+  (let ((node undo-tree-visualizer-initial-node))
+    (undo-tree-visualizer-quit)
+    (undo-tree-set node)))
+
+
+(defun undo-tree-visualizer-set (&optional pos)
+  "Set buffer to state corresponding to undo tree node
+at POS, or point if POS is nil."
+  (interactive)
+  (unless pos (setq pos (point)))
+  (let ((node (get-text-property pos 'undo-tree-node)))
+    (when node
+      ;; set parent buffer to state corresponding to node at POS
+      (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
+      (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-set node))
+      (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
+      ;; re-draw undo tree
+      (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree))
+      (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff)))))
+
+
+(defun undo-tree-visualizer-mouse-set (pos)
+  "Set buffer to state corresponding to undo tree node
+at mouse event POS."
+  (interactive "@e")
+  (undo-tree-visualizer-set (event-start (nth 1 pos))))
+
+
+(defun undo-tree-visualize-undo-to-x (&optional x)
+  "Undo to last branch point, register, or saved state.
+If X is 'branch, undo to last branch point. If X is 'register,
+undo to last register. If X is 'saved, undo to last saved state.
+
+Interactively, a single \\[universal-argument] specifies
+`branch', a double \\[universal-argument] \[universal-argument]
+spcified `saved', and a negative prefix argument specifies
+`register'."
+  (interactive "P")
+  (when (and (called-interactively-p 'any) x)
+    (setq x (prefix-numeric-value x)
+         x (cond
+            ((< x 0)  'register)
+            ((<= x 4) 'branch)
+            (t        'saved))))
+  (let ((current (undo-tree-current buffer-undo-tree))
+       r)
+    (while (and (undo-tree-node-previous current)
+               (or (undo-tree-visualize-undo) t)
+               (setq current (undo-tree-current buffer-undo-tree))
+                        ;; branch point
+               (not (or (and (or (null x) (eq x 'branch))
+                             (> (undo-tree-num-branches) 1))
+                        ;; register
+                        (and (or (null x) (eq x 'register))
+                             (setq r (undo-tree-node-register current))
+                             (undo-tree-register-data-p
+                              (setq r (registerv-data (get-register r))))
+                             (eq current (undo-tree-register-data-node r)))
+                        ;; saved state
+                        (and (or (null x) (eq x 'saved))
+                             (undo-tree-node-unmodified-p current))
+                        ))))))
+
+
+(defun undo-tree-visualize-redo-to-x (&optional x)
+  "Redo to next branch point or register.
+If X is the symbol `branch', redo to next branch point ignoring
+registers. If X is the symbol 'register', redo to next register,
+ignoring branch points.
+
+Interactively, a positive prefix argument specifies `branch', and
+a negative prefix argument specifies `register'."
+  (interactive "P")
+  (when (and (called-interactively-p 'any) x)
+    (setq x (prefix-numeric-value x)
+         x (cond
+            ((< x 0)  'register)
+            ((<= x 4) 'branch)
+            (t        'saved))))
+  (let ((current (undo-tree-current buffer-undo-tree))
+       r)
+    (while (and (undo-tree-node-next current)
+               (or (undo-tree-visualize-redo) t)
+               (setq current (undo-tree-current buffer-undo-tree))
+                        ;; branch point
+               (not (or (and (or (null x) (eq x 'branch))
+                             (> (undo-tree-num-branches) 1))
+                        ;; register
+                        (and (or (null x) (eq x 'register))
+                             (setq r (undo-tree-node-register current))
+                             (undo-tree-register-data-p
+                              (setq r (registerv-data (get-register r))))
+                             (eq current (undo-tree-register-data-node r)))
+                        ;; saved state
+                        (and (or (null x) (eq x 'saved))
+                             (undo-tree-node-unmodified-p current))
+                        ))))))
+
+
+(defun undo-tree-visualizer-toggle-timestamps ()
+  "Toggle display of time-stamps."
+  (interactive)
+  (setq undo-tree-visualizer-timestamps (not undo-tree-visualizer-timestamps))
+  (setq undo-tree-visualizer-spacing (undo-tree-visualizer-calculate-spacing))
+  ;; redraw tree
+  (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree)))
+
+
+(defun undo-tree-visualizer-scroll-left (&optional arg)
+  (interactive "p")
+  (scroll-left (or arg 1) t))
+
+
+(defun undo-tree-visualizer-scroll-right (&optional arg)
+  (interactive "p")
+  (scroll-right (or arg 1) t))
+
+
+(defun undo-tree-visualizer-scroll-up (&optional arg)
+  (interactive "P")
+  (if (or (and (numberp arg) (< arg 0)) (eq arg '-))
+      (undo-tree-visualizer-scroll-down arg)
+    ;; scroll up and expand newly-visible portion of tree
+    (unwind-protect
+       (scroll-up-command arg)
+      (undo-tree-expand-down
+       (nth (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
+           (undo-tree-node-next (undo-tree-current buffer-undo-tree)))))
+    ;; signal error if at eob
+    (when (and (not undo-tree-visualizer-needs-extending-down) (eobp))
+      (scroll-up))))
+
+
+(defun undo-tree-visualizer-scroll-down (&optional arg)
+  (interactive "P")
+  (if (or (and (numberp arg) (< arg 0)) (eq arg '-))
+      (undo-tree-visualizer-scroll-up arg)
+    ;; ensure there's enough room at top of buffer to scroll
+    (let ((scroll-lines
+          (or arg (- (window-height) next-screen-context-lines)))
+         (window-line (1- (line-number-at-pos (window-start)))))
+      (when (and undo-tree-visualizer-needs-extending-up
+                (< window-line scroll-lines))
+       (let ((inhibit-read-only t))
+         (goto-char (point-min))
+         (undo-tree-move-up (- scroll-lines window-line)))))
+    ;; scroll down and expand newly-visible portion of tree
+    (unwind-protect
+       (scroll-down-command arg)
+      (undo-tree-expand-up
+       (undo-tree-node-previous (undo-tree-current buffer-undo-tree))))
+    ;; signal error if at bob
+    (when (and (not undo-tree-visualizer-needs-extending-down) (bobp))
+      (scroll-down))))
+
+
+
+\f
+;;; =====================================================================
+;;;                    Visualizer selection mode
+
+(defun undo-tree-visualizer-selection-mode ()
+  "Major mode used to select nodes in undo-tree visualizer."
+  (interactive)
+  (setq major-mode 'undo-tree-visualizer-selection-mode)
+  (setq mode-name "undo-tree-visualizer-selection-mode")
+  (use-local-map undo-tree-visualizer-selection-map)
+  (setq cursor-type 'box)
+  (setq undo-tree-visualizer-selected-node
+       (undo-tree-current buffer-undo-tree))
+  ;; erase diff (if any), as initially selected node is identical to current
+  (when undo-tree-visualizer-diff
+    (let ((buff (get-buffer undo-tree-diff-buffer-name))
+         (inhibit-read-only t))
+      (when buff (with-current-buffer buff (erase-buffer))))))
+
+
+(defun undo-tree-visualizer-select-previous (&optional arg)
+  "Move to previous node."
+  (interactive "p")
+  (let ((node undo-tree-visualizer-selected-node))
+    (catch 'top
+      (dotimes (i arg)
+       (unless (undo-tree-node-previous node) (throw 'top t))
+       (setq node (undo-tree-node-previous node))))
+    ;; when using lazy drawing, extend tree upwards as required
+    (when undo-tree-visualizer-lazy-drawing
+      (undo-tree-expand-up undo-tree-visualizer-selected-node node))
+    ;; update diff display, if any
+    (when (and undo-tree-visualizer-diff
+              (not (eq node undo-tree-visualizer-selected-node)))
+      (undo-tree-visualizer-update-diff node))
+    ;; move to selected node
+    (goto-char (undo-tree-node-marker node))
+    (setq undo-tree-visualizer-selected-node node)))
+
+
+(defun undo-tree-visualizer-select-next (&optional arg)
+  "Move to next node."
+  (interactive "p")
+  (let ((node undo-tree-visualizer-selected-node))
+    (catch 'bottom
+      (dotimes (i arg)
+       (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node))
+         (throw 'bottom t))
+       (setq node
+             (nth (undo-tree-node-branch node) (undo-tree-node-next node)))))
+    ;; when using lazy drawing, extend tree upwards as required
+    (when undo-tree-visualizer-lazy-drawing
+      (undo-tree-expand-down undo-tree-visualizer-selected-node node))
+    ;; update diff display, if any
+    (when (and undo-tree-visualizer-diff
+              (not (eq node undo-tree-visualizer-selected-node)))
+      (undo-tree-visualizer-update-diff node))
+    ;; move to selected node
+    (goto-char (undo-tree-node-marker node))
+    (setq undo-tree-visualizer-selected-node node)))
+
+
+(defun undo-tree-visualizer-select-right (&optional arg)
+  "Move right to a sibling node."
+  (interactive "p")
+  (let ((node undo-tree-visualizer-selected-node)
+       end)
+    (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node))
+    (setq end (line-end-position))
+    (catch 'end
+      (dotimes (i arg)
+       (while (or (null node) (eq node undo-tree-visualizer-selected-node))
+         (forward-char)
+         (setq node (get-text-property (point) 'undo-tree-node))
+         (when (= (point) end) (throw 'end t)))))
+    (goto-char (undo-tree-node-marker
+               (or node undo-tree-visualizer-selected-node)))
+    (when (and undo-tree-visualizer-diff node
+              (not (eq node undo-tree-visualizer-selected-node)))
+      (undo-tree-visualizer-update-diff node))
+    (when node (setq undo-tree-visualizer-selected-node node))))
+
+
+(defun undo-tree-visualizer-select-left (&optional arg)
+  "Move left to a sibling node."
+  (interactive "p")
+  (let ((node (get-text-property (point) 'undo-tree-node))
+       beg)
+    (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node))
+    (setq beg (line-beginning-position))
+    (catch 'beg
+      (dotimes (i arg)
+       (while (or (null node) (eq node undo-tree-visualizer-selected-node))
+         (backward-char)
+         (setq node (get-text-property (point) 'undo-tree-node))
+         (when (= (point) beg) (throw 'beg t)))))
+    (goto-char (undo-tree-node-marker
+               (or node undo-tree-visualizer-selected-node)))
+    (when (and undo-tree-visualizer-diff node
+              (not (eq node undo-tree-visualizer-selected-node)))
+      (undo-tree-visualizer-update-diff node))
+    (when node (setq undo-tree-visualizer-selected-node node))))
+
+
+\f
+;;; =====================================================================
+;;;                      Visualizer diff display
+
+(defun undo-tree-visualizer-toggle-diff ()
+  "Toggle diff display in undo-tree visualizer."
+  (interactive)
+  (if undo-tree-visualizer-diff
+      (undo-tree-visualizer-hide-diff)
+    (undo-tree-visualizer-show-diff)))
+
+
+(defun undo-tree-visualizer-selection-toggle-diff ()
+  "Toggle diff display in undo-tree visualizer selection mode."
+  (interactive)
+  (if undo-tree-visualizer-diff
+      (undo-tree-visualizer-hide-diff)
+    (let ((node (get-text-property (point) 'undo-tree-node)))
+      (when node (undo-tree-visualizer-show-diff node)))))
+
+
+(defun undo-tree-visualizer-show-diff (&optional node)
+  ;; show visualizer diff display
+  (setq undo-tree-visualizer-diff t)
+  (let ((buff (with-current-buffer undo-tree-visualizer-parent-buffer
+               (undo-tree-diff node)))
+       (display-buffer-mark-dedicated 'soft)
+       win)
+    (setq win (split-window))
+    (set-window-buffer win buff)
+    (shrink-window-if-larger-than-buffer win)))
+
+
+(defun undo-tree-visualizer-hide-diff ()
+  ;; hide visualizer diff display
+  (setq undo-tree-visualizer-diff nil)
+  (let ((win (get-buffer-window undo-tree-diff-buffer-name)))
+    (when win (with-selected-window win (kill-buffer-and-window)))))
+
+
+(defun undo-tree-diff (&optional node)
+  ;; Create diff between current state and NODE (or previous state, if NODE is
+  ;; null). Returns buffer containing diff.
+  (let (tmpfile buff)
+    ;; generate diff
+    (let ((undo-tree-inhibit-kill-visualizer t)
+         (current (undo-tree-current buffer-undo-tree)))
+      (undo-tree-set (or node (undo-tree-node-previous current) current)
+                    'preserve-timestamps)
+      (setq tmpfile (diff-file-local-copy (current-buffer)))
+      (undo-tree-set current 'preserve-timestamps))
+    (setq buff (diff-no-select
+               (current-buffer) tmpfile nil 'noasync
+               (get-buffer-create undo-tree-diff-buffer-name)))
+    ;; delete process messages and useless headers from diff buffer
+    (with-current-buffer buff
+      (goto-char (point-min))
+      (delete-region (point) (1+ (line-end-position 3)))
+      (goto-char (point-max))
+      (forward-line -2)
+      (delete-region (point) (point-max))
+      (setq cursor-type nil)
+      (setq buffer-read-only t))
+    buff))
+
+
+(defun undo-tree-visualizer-update-diff (&optional node)
+  ;; update visualizer diff display to show diff between current state and
+  ;; NODE (or previous state, if NODE is null)
+  (with-current-buffer undo-tree-visualizer-parent-buffer
+    (undo-tree-diff node))
+  (let ((win (get-buffer-window undo-tree-diff-buffer-name)))
+    (when win
+      (balance-windows)
+      (shrink-window-if-larger-than-buffer win))))
+
+
+
+(provide 'undo-tree)
+
+;;; undo-tree.el ends here
diff --git a/elisp/local/volatile-highlights.el b/elisp/local/volatile-highlights.el
new file mode 100644 (file)
index 0000000..afe9fea
--- /dev/null
@@ -0,0 +1,802 @@
+;;; volatile-highlights.el --- Minor mode for visual feedback on some operations.
+
+;; Copyright (C) 2001, 2010-2013 K-talo Miyazaki, all rights reserved.
+
+;; Author: K-talo Miyazaki <Keitaro dot Miyazaki at gmail dot com>
+;; Created: 03 October 2001. (as utility functions in my `.emacs' file.)
+;;          14 March   2010. (re-written as library `volatile-highlights.el')
+;; Keywords: emulations convenience wp
+;; Revision: $Id: 05a87ee2b07b56d0d15be57cea3d77f30da5411e $
+;; URL: http://www.emacswiki.org/emacs/download/volatile-highlights.el
+;; GitHub: http://github.com/k-talo/volatile-highlights.el
+;; Version: 1.10
+;; Contributed by: Ryan Thompson.
+
+;; This file is not part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Overview
+;; ========
+;; This library provides minor mode `volatile-highlight-mode', which
+;; brings visual feedback to some operations by highlighting portions
+;; relating to the operations.
+;;
+;; All of highlights made by this library will be removed
+;; when any new command is executed.
+;;
+;;
+;; INSTALLING
+;; ==========
+;; To install this library, save this file to a directory in your
+;; `load-path' (you can view the current `load-path' using "C-h v
+;; load-path" within Emacs), then add the following line to your
+;; .emacs start up file:
+;;
+;;    (require 'volatile-highlights)
+;;    (volatile-highlights-mode t)
+;;
+;; USING
+;; =====
+;; To toggle volatile highlighting, type `M-x volatile-highlights-mode RET'.
+;;
+;; Currently, operations listed below will be highlighted While the minor mode
+;; `volatile-highlights-mode' is on:
+;;
+;;    - `undo':
+;;      Volatile highlights will be put on the text inserted by `undo'.
+;;
+;;    - `yank' and `yank-pop':
+;;      Volatile highlights will be put on the text inserted by `yank'
+;;      or `yank-pop'.
+;;
+;;    - `kill-region', `kill-line', any other killing function:
+;;      Volatile highlights will be put at the positions where the
+;;      killed text used to be.
+;;
+;;    - `delete-region':
+;;      Same as `kill-region', but not as reliable since
+;;      `delete-region' is an inline function.
+;;
+;;    - `find-tag':
+;;      Volatile highlights will be put on the tag name which was found
+;;      by `find-tag'.
+;;
+;;    - `occur-mode-goto-occurrence' and `occur-mode-display-occurrence':
+;;      Volatile highlights will be put on the occurrence which is selected
+;;      by `occur-mode-goto-occurrence' or `occur-mode-display-occurrence'.
+;;
+;;    - Non incremental search operations:
+;;      Volatile highlights will be put on the the text found by
+;;      commands listed below:
+;;
+;;        `nonincremental-search-forward'
+;;        `nonincremental-search-backward'
+;;        `nonincremental-re-search-forward'
+;;        `nonincremental-re-search-backward'
+;;        `nonincremental-repeat-search-forward'
+;;        `nonincremental-repeat-search-backwar'
+;;
+;; Highlighting support for each operations can be turned on/off individually
+;; via customization. Also check out the customization group
+;;
+;;   `M-x customize-group RET volatile-highlights RET'
+
+
+;;; Change Log:
+
+;; v1.10  Thu Mar 21 22:37:27 2013 JST
+;;   - Use inherit in face definition when detected.
+;;   - Suppress compiler warnings regarding to emacs/xemacs private
+;;     functions by file local variable.
+;;
+;; v1.9  Tue Mar  5 00:52:35 2013 JST
+;;   - Fixed errors in shell caused by dummy functions.
+;;
+;; v1.8  Wed Feb 15 00:08:14 2012 JST
+;;   - Added "Contributed by: " line in header.
+;;   - Added extension for hideshow.
+;;
+;; v1.7  Mon Feb 13 23:31:18 2012 JST
+;;   - Fixed a bug required features are not loaded.
+;;
+;; v1.6  Thu Feb  2 06:59:48 2012 JST
+;;   - Removed extensions for non standard features.
+;;   - Suppress compiler warning "function `vhl/.make-list-string'
+;;     defined multiple times".
+;;   - Fixed compiler error "Symbol's function definition is void:
+;;     vhl/.make-list-string".
+;;
+;;  v1.5  Tue Jan 31 22:19:04 2012 JST
+;;   - Added extension for highlighting the position where text was
+;;     killed from.
+;;   - Added extension for highlighting the position where text was
+;;     deleted from.
+;;   - Provide a macro `vhl/define-extension' for easily defining new
+;;     simple extensions with a single line of code. For usage
+;;     examples, see the definitions of the undo, yank, kill, and
+;;     delete extensions.
+;;
+;;  v1.4  Sun Jan 15 20:23:58 2012 JST
+;;   - Suppress compiler warnings regarding to emacs/xemacs private
+;;     functions.
+;;   - Fixed bugs which occurs to xemacs.
+;;
+;;  v1.3, Sat Dec 18 16:44:14 2010 JST
+;;   - Added extension for non-incremental search operations.
+;;   - Fixed a bug that highlights won't be appear when
+;;     occurrences is in folded line.
+;;
+;;  v1.2, Tue Nov 30 01:07:48 2010 JST
+;;   - In `vhl/ext/occur', highlight all occurrences.
+;;
+;;  v1.1, Tue Nov  9 20:36:09 2010 JST
+;;   - Fixed a bug that mode toggling feature was not working.
+
+;;; Code:
+
+(defconst vhl/version "1.8")
+
+(eval-when-compile
+  (require 'cl)
+  (require 'easy-mmode)
+  (require 'advice))
+
+(provide 'volatile-highlights)
+
+;;;============================================================================
+;;;
+;;;  Private Variables.
+;;;
+;;;============================================================================
+
+(eval-and-compile
+  (defconst vhl/.xemacsp (string-match "XEmacs" emacs-version)
+    "A flag if the emacs is xemacs or not."))
+
+(defvar vhl/.hl-lst nil
+  "List of volatile highlights.")
+
+;;;============================================================================
+;;;
+;;;  Faces.
+;;;
+;;;============================================================================
+
+(defgroup volatile-highlights nil
+  "Visual feedback on operations."
+  :group 'editing)
+
+
+;; Borrowed from `slime.el'.
+(defun vhl/.face-inheritance-possible-p ()
+  "Return true if the :inherit face attribute is supported."
+  (assq :inherit custom-face-attributes))
+
+(defface vhl/default-face
+  (cond
+   ((or vhl/.xemacsp
+        (not (vhl/.face-inheritance-possible-p)))
+    '((((class color) (background light))
+       (:background "yellow1"))
+      (((class color) (background dark))
+       (:background "SkyBlue4"))
+      (t :inverse-video t)))
+   (t
+    '((t
+       :inherit secondary-selection
+       ))))
+    "Face used for volatile highlights."
+    :group 'volatile-highlights)
+
+;;;============================================================================
+;;;
+;;;  Minor Mode Definition.
+;;;
+;;;============================================================================
+(easy-mmode-define-minor-mode
+ volatile-highlights-mode "Minor mode for visual feedback on some operations."
+ :global t
+ :init-value nil
+ :lighter " VHl"
+ (if volatile-highlights-mode
+     (vhl/load-extensions)
+   (vhl/unload-extensions)))
+
+
+(defcustom Vhl/highlight-zero-width-ranges nil
+  "If t, highlight the positions of zero-width ranges.
+
+For example, if a deletion is highlighted, then the position
+where the deleted text used to be would be highlighted."
+  :type 'boolean
+  :group 'volatile-highlights)
+
+;;;============================================================================
+;;;
+;;;  Public Functions/Commands.
+;;;
+;;;============================================================================
+
+;;-----------------------------------------------------------------------------
+;; (vhl/add-range BEG END &OPTIONAL BUF FACE) => VOID
+;;-----------------------------------------------------------------------------
+(defun vhl/add-range (beg end &optional buf face)
+  "Add a volatile highlight to the buffer `BUF' at the position
+specified by `BEG' and `END' using the face `FACE'.
+
+When the buffer `BUF' is not specified or its value is `nil',
+volatile highlight will be added to current buffer.
+
+When the face `FACE' is not specified or its value is `nil',
+the default face `vhl/default-face' will
+be used as the value."
+  (let* ((face (or face 'vhl/default-face))
+                (hl (vhl/.make-hl beg end buf face)))
+       (setq vhl/.hl-lst
+                 (cons hl vhl/.hl-lst))
+       (add-hook 'pre-command-hook 'vhl/clear-all)))
+(define-obsolete-function-alias 'vhl/add 'vhl/add-range "1.5")
+
+;;-----------------------------------------------------------------------------
+;; (vhl/add-position POS &OPTIONAL BUF FACE) => VOID
+;;-----------------------------------------------------------------------------
+(defun vhl/add-position (pos &rest other-args)
+  "Highlight buffer position POS as a change.
+
+If Vhl/highlight-zero-width-ranges is nil, do nothing.
+
+Optional args are the same as `vhl/add-range'."
+  (when (and Vhl/highlight-zero-width-ranges (not (zerop (buffer-size))))
+    (when (> pos (buffer-size))
+        (setq pos (- pos 1)))
+    (apply 'vhl/add-range pos (+ pos 1) other-args)))
+
+;;-----------------------------------------------------------------------------
+;; (vhl/clear-all) => VOID
+;;-----------------------------------------------------------------------------
+(defun vhl/clear-all ()
+  "Clear all volatile highlights."
+  (interactive)
+  (while vhl/.hl-lst
+       (vhl/.clear-hl (car vhl/.hl-lst))
+       (setq vhl/.hl-lst
+                 (cdr vhl/.hl-lst)))
+         (remove-hook 'pre-command-hook 'vhl/clear-all))
+
+;;-----------------------------------------------------------------------------
+;; (vhl/force-clear-all) => VOID
+;;-----------------------------------------------------------------------------
+(defun vhl/force-clear-all ()
+  "Force clear all volatile highlights in current buffer."
+  (interactive)
+  (vhl/.force-clear-all-hl))
+
+;;;============================================================================
+;;;
+;;;  Private Functions.
+;;;
+;;;============================================================================
+
+;;-----------------------------------------------------------------------------
+;; (vhl/.make-hl BEG END BUF FACE) => HIGHLIGHT
+;;-----------------------------------------------------------------------------
+(defun vhl/.make-hl (beg end buf face)
+  "Make a volatile highlight at the position specified by `BEG' and `END'."
+  (let (hl)
+       (cond
+        (vhl/.xemacsp
+         ;; XEmacs
+         (setq hl (make-extent beg end buf))
+         (set-extent-face hl face)
+         (highlight-extent hl t)
+         (set-extent-property hl 'volatile-highlights t))
+        (t
+         ;; GNU Emacs
+         (setq hl (make-overlay beg end buf))
+         (overlay-put hl 'face face)
+         (overlay-put hl 'priority 1)
+         (overlay-put hl 'volatile-highlights t)))
+        hl))
+
+;;-----------------------------------------------------------------------------
+;; (vhl/.clear-hl HIGHLIGHT) => VOID
+;;-----------------------------------------------------------------------------
+(defun vhl/.clear-hl (hl)
+  "Clear one highlight."
+  (cond
+   ;; XEmacs (not tested!)
+   (vhl/.xemacsp
+       (and (extentp hl)
+                (delete-extent hl)))
+   ;; GNU Emacs
+   (t
+       (and (overlayp hl)
+                (delete-overlay hl)))))
+
+;;-----------------------------------------------------------------------------
+;; (vhl/.force-clear-all-hl) => VOID
+;;-----------------------------------------------------------------------------
+(defun vhl/.force-clear-all-hl ()
+  "Force clear all volatile highlights in current buffer."
+  (cond
+   ;; XEmacs (not tested!)
+   (vhl/.xemacsp
+      (map-extents (lambda (hl maparg)
+                     (and (extent-property hl 'volatile-highlights)
+                                                 (vhl/.clear-hl hl)))))
+   ;; GNU Emacs
+   (t
+       (save-restriction
+         (widen)
+         (mapcar (lambda (hl)
+                               (and (overlay-get hl 'volatile-highlights)
+                                        (vhl/.clear-hl hl)))
+                         (overlays-in (point-min) (point-max)))))))
+
+;;;============================================================================
+;;;
+;;;  Functions to manage extensions.
+;;;
+;;;============================================================================
+(defvar vhl/.installed-extensions nil)
+
+(defun vhl/install-extension (sym)
+  (let ((fn-on  (intern (format "vhl/ext/%s/on" sym)))
+        (fn-off (intern (format "vhl/ext/%s/off" sym)))
+        (cust-name (intern (format "vhl/use-%s-extension-p" sym))))
+    (pushnew sym vhl/.installed-extensions)
+    (eval `(defcustom ,cust-name t
+             ,(format "A flag if highlighting support for `%s' is on or not." sym)
+             :type 'boolean
+             :group 'volatile-highlights
+             :set (lambda (sym-to-set val)
+                    (set-default sym-to-set val)
+                    (if val
+                        (when volatile-highlights-mode
+                          (vhl/load-extension sym-to-set))
+                      (vhl/unload-extension sym-to-set)))))))
+
+(defun vhl/load-extension (sym)
+  (let ((fn-on  (intern (format "vhl/ext/%s/on" sym)))
+        (cust-name (intern (format "vhl/use-%s-extension-p" sym))))
+    (if (functionp fn-on)
+        (when (and (boundp cust-name)
+                   (eval cust-name))
+          (apply fn-on nil))
+      (message "[vhl] No load function for extension  `%s'" sym))))
+
+(defun vhl/unload-extension (sym)
+  (let ((fn-off (intern (format "vhl/ext/%s/off" sym))))
+    (if (functionp fn-off)
+        (apply fn-off nil)
+      (message "[vhl] No unload function for extension  `%s'" sym))))
+
+(defun vhl/load-extensions ()
+  (dolist (sym vhl/.installed-extensions)
+    (vhl/load-extension sym)))
+
+(defun vhl/unload-extensions ()
+  (dolist (sym vhl/.installed-extensions)
+    (vhl/unload-extension sym)))
+
+;;;============================================================================
+;;;
+;;;  Utility functions/macros for extensions.
+;;;
+;;;============================================================================
+(defun vhl/advice-defined-p (fn-name class ad-name)
+  (and (ad-is-advised fn-name)
+       (assq ad-name
+             (ad-get-advice-info-field fn-name class))))
+
+(defun vhl/disable-advice-if-defined (fn-name class ad-name)
+  (when (vhl/advice-defined-p fn-name class ad-name)
+       (ad-disable-advice fn-name class ad-name)
+       (ad-activate fn-name)))
+
+(defun vhl/.make-vhl-on-change (beg end len-removed)
+  (let ((insert-p (zerop len-removed)))
+    (if insert-p
+        ;; Highlight the insertion
+        (vhl/add-range beg end)
+      ;; Highlight the position of the deletion
+      (vhl/add-position beg))))
+
+(defmacro vhl/give-advice-to-make-vhl-on-changes (fn-name)
+  (let* ((ad-name (intern (concat "vhl/make-vhl-on-"
+                                 (format "%s" fn-name)))))
+    (or (symbolp fn-name)
+        (error "vhl/give-advice-to-make-vhl-on-changes: `%s' is not type of symbol." fn-name))
+    `(progn
+       (defadvice ,fn-name (around
+                              ,ad-name
+                              (&rest args))
+         (add-hook 'after-change-functions
+                   'vhl/.make-vhl-on-change)
+         (unwind-protect
+             ad-do-it
+           (remove-hook 'after-change-functions
+                        'vhl/.make-vhl-on-change)))
+       ;; Enable advice.
+       (ad-enable-advice (quote ,fn-name) 'around (quote ,ad-name))
+       (ad-activate (quote ,fn-name)))))
+
+(defmacro vhl/cancel-advice-to-make-vhl-on-changes (fn-name)
+  (let ((ad-name (intern (concat "vhl/make-vhl-on-"
+                                 (format "%s" fn-name)))))
+    `(vhl/disable-advice-if-defined (quote ,fn-name) 'around (quote ,ad-name))))
+
+(defun vhl/require-noerror (feature &optional filename)
+  (condition-case c
+      (require feature)
+    (file-error nil)))
+
+(eval-and-compile
+;; Utility function by Ryan Thompson.
+(defun vhl/.make-list-string (items)
+  "Makes an English-style list from a list of strings.
+
+Converts a list of strings into a string that lists the items
+separated by commas, as well as the word `and' before the last
+item. In other words, returns a string of the way those items
+would be listed in english.
+
+This is included as a private support function for generating
+lists of symbols to be included docstrings of auto-generated
+extensions."
+  (assert (listp items))
+  (cond ((null items)
+         ;; Zero items
+         "")
+        ((null (cdr items))
+         ;; One item
+         (assert (stringp (first items)))
+         (format "%s" (first items)))
+        ((null (cddr items))
+         ;; Two items
+         (assert (stringp (first items)))
+         (assert (stringp (second items)))
+         (apply 'format "%s and %s" items))
+        ((null (cdddr items))
+         ;; Three items
+         (assert (stringp (first items)))
+         (assert (stringp (second items)))
+         (assert (stringp (third items)))
+         (apply 'format "%s, %s, and %s" items))
+        (t
+         ;; 4 or more items
+         (format "%s, %s" (first items) (vhl/.make-list-string (rest items)))))))
+
+;; The following makes it trivial to&nbs