Mercurial > hg > xemacs-beta
annotate lisp/undo-stack.el @ 5818:15b0715c204d
Avoid passing patterns to with charset property to FcNameUnparse.
Prevents crash reported by Raymond Toy.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 18 Oct 2014 21:20:42 +0900 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 428 | 1 ;;; undo-stack.el --- An "undoable stack" object. |
| 2 | |
| 3 ;; Copyright (C) 1997 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1996 Ben Wing. | |
| 5 | |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: extensions, dumped | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
14 ;; option) any later version. |
| 428 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
19 ;; for more details. |
| 428 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 23 |
| 24 ;;; Synched up with: Not in FSF. | |
| 25 | |
| 26 ;;; Commentary: | |
| 27 | |
| 28 ;; This file is dumped with XEmacs. | |
| 29 | |
| 30 ;; An "undoable stack" is an object that can be used to implement | |
| 31 ;; a history of positions, with undo and redo. Conceptually, it | |
| 32 ;; is the kind of data structure used to keep track of (e.g.) | |
| 33 ;; visited Web pages, so that the "Back" and "Forward" operations | |
| 34 ;; in the browser work. Basically, I can successively visit a | |
| 35 ;; number of Web pages through links, and then hit "Back" a | |
| 36 ;; few times to go to previous positions, and then "Forward" a | |
| 37 ;; few times to reverse this process. This is similar to an | |
| 38 ;; "undo" and "redo" mechanism. | |
| 39 | |
| 40 ;; Note that Emacs does not standardly contain structures like | |
| 41 ;; this. Instead, it implements history using either a ring | |
| 42 ;; (the kill ring, the mark ring), or something like the undo | |
| 43 ;; stack, where successive "undo" operations get recorded as | |
| 44 ;; normal modifications, so that if you do a bunch of successive | |
| 45 ;; undo's, then something else, then start undoing, you will | |
| 46 ;; be redoing all your undo's back to the point before you did | |
| 47 ;; the undo's, and then further undo's will act like the previous | |
| 48 ;; round of undo's. I think that both of these paradigms are | |
| 49 ;; inferior to the "undoable-stack" paradigm because they're | |
| 50 ;; confusing and difficult to keep track of. | |
| 51 | |
| 52 ;; Conceptually, imagine a position history like this: | |
| 53 | |
| 54 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
| 55 ;; ^^ | |
| 56 | |
| 57 ;; where the arrow indicates where you currently are. "Going back" | |
| 58 ;; and "going forward" just amount to moving the arrow. However, | |
| 59 ;; what happens if the history state is this: | |
| 60 | |
| 61 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
| 62 ;; ^^ | |
| 63 | |
| 64 ;; and then I visit new positions (7) and (8)? In the most general | |
| 65 ;; implementation, you've just caused a new branch like this: | |
| 66 | |
| 67 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
| 68 ;; | | |
| 69 ;; | | |
| 70 ;; 7 -> 8 | |
| 71 ;; ^^ | |
| 72 | |
| 73 ;; But then you can end up with a whole big tree, and you need | |
| 74 ;; more sophisticated ways of navigating ("Forward" might involve | |
| 75 ;; a choice of paths to follow) and managing its size (if you don't | |
| 76 ;; want to keep unlimited history, you have to truncate at some point, | |
| 77 ;; and how do you truncate a tree?) | |
| 78 | |
| 79 ;; My solution to this is just to insert the new positions like | |
| 80 ;; this: | |
| 81 | |
| 82 ;; 1 -> 2 -> 3 -> 4 -> 7 -> 8 -> 5 -> 6 | |
| 83 ;; ^^ | |
| 84 | |
| 85 ;; (Netscape, I think, would just truncate 5 and 6 completely, | |
| 86 ;; but that seems a bit drastic. In the Emacs-standard "ring" | |
| 87 ;; structure, this problem is avoided by simply moving 5 and 6 | |
| 88 ;; to the beginning of the ring. However, it doesn't seem | |
| 89 ;; logical to me to have "going back past 1" get you to 6.) | |
| 90 | |
| 91 ;; Now what if we have a "maximum" size of (say) 7 elements? | |
| 92 ;; When we add 8, we could truncate either 1 or 6. Since 5 and | |
| 93 ;; 6 are "undone" positions, we should presumably truncate | |
| 94 ;; them before 1. So, adding 8 truncates 6, adding 9 truncates | |
| 95 ;; 5, and adding 10 truncates 1 because there is nothing more | |
| 96 ;; that is forward of the insertion point. | |
| 97 | |
| 98 ;; Interestingly, this method of truncation is almost like | |
| 99 ;; how a ring would truncate. A ring would move 5 and 6 | |
| 100 ;; around to the back, like this: | |
| 101 | |
| 102 ;; 5 -> 6 -> 1 -> 2 -> 3 -> 4 -> 7 -> 8 | |
| 103 ;; ^^ | |
| 104 | |
| 105 ;; However, when 8 is added, the ring truncates 5 instead of | |
| 106 ;; 6, which is less than optimal. | |
| 107 | |
| 108 ;; Conceptually, we can implement the "undoable stack" using | |
| 109 ;; two stacks of a sort called "truncatable stack", which are | |
| 110 ;; just simple stacks, but where you can truncate elements | |
| 111 ;; off of the bottom of the stack. Then, the undoable stack | |
| 112 | |
| 113 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
| 114 ;; ^^ | |
| 115 | |
| 116 ;; is equivalent to two truncatable stacks: | |
| 117 | |
| 118 ;; 4 <- 3 <- 2 <- 1 | |
| 119 ;; 5 <- 6 | |
| 120 | |
| 121 ;; where I reversed the direction to accord with the probable | |
| 122 ;; implementation of a standard list. To do another undo, | |
| 123 ;; I pop 4 off of the first stack and move it to the top of | |
| 124 ;; the second stack. A redo operation does the opposite. | |
| 125 ;; To truncate to the proper size, first chop off 6, then 5, | |
| 126 ;; then 1 -- in all cases, truncating off the bottom. | |
| 127 | |
| 128 ;;; Code: | |
| 129 | |
| 130 (define-error 'trunc-stack-bottom "Bottom of stack reached") | |
| 131 | |
| 132 (defsubst trunc-stack-stack (stack) | |
| 133 ;; return the list representing the trunc-stack's elements. | |
| 134 ;; the head of the list is the most recent element. | |
| 135 (aref stack 1)) | |
| 136 | |
| 137 (defsubst trunc-stack-length (stack) | |
| 138 ;; return the number of elements in the trunc-stack. | |
| 139 (aref stack 2)) | |
| 140 | |
| 141 (defsubst set-trunc-stack-stack (stack new) | |
| 142 ;; set the list representing the trunc-stack's elements. | |
| 143 (aset stack 1 new)) | |
| 144 | |
| 145 (defsubst set-trunc-stack-length (stack new) | |
| 146 ;; set the length of the trunc-stack. | |
| 147 (aset stack 2 new)) | |
| 148 | |
| 149 ;; public functions: | |
| 150 | |
| 151 (defun make-trunc-stack () | |
| 152 ;; make an empty trunc-stack. | |
| 153 (vector 'trunc-stack nil 0)) | |
| 154 | |
| 155 (defun trunc-stack-push (stack el) | |
| 156 ;; push a new element onto the head of the trunc-stack. | |
| 157 (set-trunc-stack-stack stack (cons el (trunc-stack-stack stack))) | |
| 158 (set-trunc-stack-length stack (1+ (trunc-stack-length stack)))) | |
| 159 | |
| 160 (defun trunc-stack-top (stack &optional n) | |
| 161 ;; return the nth topmost element from the trunc-stack. | |
| 162 ;; signal an error if the stack doesn't have that many elements. | |
| 163 (or n (setq n 0)) | |
| 164 (if (>= n (trunc-stack-length stack)) | |
| 165 (signal-error 'trunc-stack-bottom (list stack)) | |
| 166 (nth n (trunc-stack-stack stack)))) | |
| 167 | |
| 168 (defun trunc-stack-pop (stack) | |
| 169 ;; pop and return the topmost element from the stack. | |
| 170 (prog1 (trunc-stack-top stack) | |
| 171 (set-trunc-stack-stack stack (cdr (trunc-stack-stack stack))) | |
| 172 (set-trunc-stack-length stack (1- (trunc-stack-length stack))))) | |
| 173 | |
| 174 (defun trunc-stack-truncate (stack &optional n) | |
| 175 ;; truncate N items off the bottom of the stack. If the stack is | |
| 176 ;; not that big, it just becomes empty. | |
| 177 (or n (setq n 1)) | |
| 178 (if (> n 0) | |
| 179 (let ((len (trunc-stack-length stack))) | |
| 180 (if (>= n len) | |
| 181 (progn | |
| 182 (set-trunc-stack-length stack 0) | |
| 183 (set-trunc-stack-stack stack nil)) | |
| 184 (setcdr (nthcdr (1- (- len n)) (trunc-stack-stack stack)) nil) | |
| 185 (set-trunc-stack-length stack (- len n)))))) | |
| 186 | |
| 187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 188 | |
| 189 ;;; FMH! FMH! FMH! This object-oriented stuff doesn't really work | |
| 190 ;;; properly without built-in structures (vectors suck) and without | |
| 191 ;;; public and private functions and fields. | |
| 192 | |
| 193 (defsubst undoable-stack-max (stack) | |
| 194 (aref stack 1)) | |
| 195 | |
| 196 (defsubst undoable-stack-a (stack) | |
| 197 (aref stack 2)) | |
| 198 | |
| 199 (defsubst undoable-stack-b (stack) | |
| 200 (aref stack 3)) | |
| 201 | |
| 202 ;; public functions: | |
| 203 | |
| 204 (defun make-undoable-stack (max) | |
| 205 ;; make an empty undoable stack of max size MAX. | |
| 206 (vector 'undoable-stack max (make-trunc-stack) (make-trunc-stack))) | |
| 207 | |
| 208 (defsubst set-undoable-stack-max (stack new) | |
| 209 ;; change the max size of an undoable stack. | |
| 210 (aset stack 1 new)) | |
| 211 | |
| 212 (defun undoable-stack-a-top (stack) | |
| 213 ;; return the topmost element off the "A" stack of an undoable stack. | |
| 214 ;; this is the most recent position pushed on the undoable stack. | |
| 215 (trunc-stack-top (undoable-stack-a stack))) | |
| 216 | |
| 217 (defun undoable-stack-a-length (stack) | |
| 218 (trunc-stack-length (undoable-stack-a stack))) | |
| 219 | |
| 220 (defun undoable-stack-b-top (stack) | |
| 221 ;; return the topmost element off the "B" stack of an undoable stack. | |
| 222 ;; this is the position that will become the most recent position, | |
| 223 ;; after a redo operation. | |
| 224 (trunc-stack-top (undoable-stack-b stack))) | |
| 225 | |
| 226 (defun undoable-stack-b-length (stack) | |
| 227 (trunc-stack-length (undoable-stack-b stack))) | |
| 228 | |
| 229 (defun undoable-stack-push (stack el) | |
| 230 ;; push an element onto the stack. | |
| 231 (let* | |
| 232 ((lena (trunc-stack-length (undoable-stack-a stack))) | |
| 233 (lenb (trunc-stack-length (undoable-stack-b stack))) | |
| 234 (max (undoable-stack-max stack)) | |
| 235 (len (+ lena lenb))) | |
| 236 ;; maybe truncate some elements. We have to deal with the | |
| 237 ;; possibility that we have more elements than our max | |
| 238 ;; (someone might have reduced the max). | |
| 239 (if (>= len max) | |
| 240 (let ((must-nuke (1+ (- len max)))) | |
| 241 ;; chop off must-nuke elements from the B stack. | |
| 242 (trunc-stack-truncate (undoable-stack-b stack) must-nuke) | |
| 243 ;; but if there weren't that many elements to chop, | |
| 244 ;; take the rest off the A stack. | |
| 245 (if (< lenb must-nuke) | |
| 246 (trunc-stack-truncate (undoable-stack-a stack) | |
| 247 (- must-nuke lenb))))) | |
| 248 (trunc-stack-push (undoable-stack-a stack) el))) | |
| 249 | |
| 250 (defun undoable-stack-pop (stack) | |
| 251 ;; pop an element off the stack. | |
| 252 (trunc-stack-pop (undoable-stack-a stack))) | |
| 253 | |
| 254 (defun undoable-stack-undo (stack) | |
| 255 ;; transfer an element from the top of A to the top of B. | |
| 256 ;; return value is undefined. | |
| 257 (trunc-stack-push (undoable-stack-b stack) | |
| 258 (trunc-stack-pop (undoable-stack-a stack)))) | |
| 259 | |
| 260 (defun undoable-stack-redo (stack) | |
| 261 ;; transfer an element from the top of B to the top of A. | |
| 262 ;; return value is undefined. | |
| 263 (trunc-stack-push (undoable-stack-a stack) | |
| 264 (trunc-stack-pop (undoable-stack-b stack)))) | |
| 265 | |
| 266 | |
| 267 ;;; undo-stack.el ends here |