/[cmucl]/src/hemlock/text.lisp
ViewVC logotype

Contents of /src/hemlock/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +1 -3 lines
Fix headed boilerplate.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/text.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Bill Chiles
13 ;;;
14 ;;; This file contains stuff that operates on units of texts, such as
15 ;;; paragraphs, sentences, lines, and words.
16 ;;;
17
18 (in-package "HEMLOCK")
19
20 ;;;; -- New Variables --
21
22 (defhvar "Paragraph Delimiter Function"
23 "The function that returns whether or not the current line should break the
24 paragraph."
25 :value 'default-para-delim-function)
26
27 ;;; The standard paragraph delimiting function is DEFAULT-PARA-DELIM-FUNCTION
28 (defun default-para-delim-function (mark)
29 "Return whether or not to break on this line."
30 (paragraph-delimiter-attribute-p (next-character mark)))
31
32 ;;;; -- Paragraph Commands --
33
34 (defcommand "Forward Paragraph" (p)
35 "moves point to the end of the current (next) paragraph."
36 "moves point to the end of the current (next) paragraph."
37 (let ((point (current-point)))
38 (unless (paragraph-offset point (or p 1))
39 (buffer-end point)
40 (editor-error))))
41
42 (defcommand "Backward Paragraph" (p)
43 "moves point to the start of the current (previous) paragraph."
44 "moves point to the start of the current (previous) paragraph."
45 (let ((point (current-point)))
46 (unless (paragraph-offset point (- (or p 1)))
47 (buffer-start point)
48 (editor-error))))
49
50 (defcommand "Mark Paragraph" (p)
51 "Put mark and point around current or next paragraph.
52 A paragraph is delimited by a blank line, a line beginning with a
53 special character (@,\,-,',and .), or it is begun with a line with at
54 least one whitespace character starting it. Prefixes are ignored or
55 skipped over before determining if a line starts or delimits a
56 paragraph."
57 "Put mark and point around current or next paragraph."
58 (declare (ignore p))
59 (let* ((point (current-point))
60 (mark (copy-mark point :temporary)))
61 (if (mark-paragraph point mark)
62 (push-buffer-mark mark t)
63 (editor-error))))
64
65 (defun mark-paragraph (mark1 mark2)
66 "Mark the next or current paragraph, setting mark1 to the beginning and mark2
67 to the end. This uses \"Fill Prefix\", and mark1 is always on the first
68 line of the paragraph. If no paragraph is found, then the marks are not
69 moved, and nil is returned."
70 (with-mark ((tmark1 mark1)
71 (tmark2 mark2))
72 (let* ((prefix (value fill-prefix))
73 (prefix-len (length prefix))
74 (paragraphp (paragraph-offset tmark2 1)))
75 (when (or paragraphp
76 (and (last-line-p tmark2)
77 (end-line-p tmark2)
78 (not (blank-line-p (mark-line tmark2)))))
79 (mark-before (move-mark tmark1 tmark2))
80 (%fill-paragraph-start tmark1 prefix prefix-len)
81 (move-mark mark1 tmark1)
82 (move-mark mark2 tmark2)))))
83
84
85
86 (eval-when (compile eval)
87
88 ;;; %MARK-TO-PARAGRAPH moves mark to next immediate (current)
89 ;;; paragraph in the specified direction. Nil is returned when no
90 ;;; paragraph is found. NOTE: the order of the arguments to OR within the
91 ;;; first branch of the COND must be as it is, and mark must be at the
92 ;;; beginning of the line it is on.
93 (defmacro %mark-to-paragraph (mark prefix prefix-length
94 &optional (direction :forward))
95 `(do ((skip-prefix-p)
96 (paragraph-delim-function (value paragraph-delimiter-function)))
97 (nil)
98 (setf skip-prefix-p
99 (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length)))
100 (if skip-prefix-p (character-offset ,mark ,prefix-length))
101 (let ((next-char (next-character ,mark)))
102 (cond ((and (not (blank-after-p ,mark))
103 (or (whitespace-attribute-p next-char)
104 (not (funcall paragraph-delim-function ,mark))))
105 (return (if skip-prefix-p (line-start ,mark) ,mark)))
106 (,(if (eq direction :forward)
107 `(last-line-p ,mark)
108 `(first-line-p ,mark))
109 (if skip-prefix-p (line-start ,mark))
110 (return nil)))
111 (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0))))
112
113
114 ;;; %PARAGRAPH-OFFSET-AUX is the inner loop of PARAGRAPH-OFFSET. It
115 ;;; moves over a paragraph to find the beginning or end depending on
116 ;;; direction. Prefixes on a line are ignored or skipped over before it
117 ;;; is determined if the line is a paragraph boundary.
118 (defmacro %paragraph-offset-aux (mark prefix prefix-length
119 &optional (direction :forward))
120 `(do ((paragraph-delim-function (value paragraph-delimiter-function))
121 (skip-prefix-p))
122 (nil)
123 (setf skip-prefix-p
124 (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length)))
125 (if skip-prefix-p (character-offset ,mark ,prefix-length))
126 (cond ((or (blank-after-p ,mark)
127 (funcall paragraph-delim-function ,mark))
128 (return (line-start ,mark)))
129 (,(if (eq direction :forward)
130 `(last-line-p ,mark)
131 `(first-line-p ,mark))
132 (return ,(if (eq direction :forward)
133 `(line-end ,mark)
134 `(line-start ,mark)))))
135 (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0)))
136
137 ); (eval-when (compile eval)
138
139
140
141 ;;; PARAGRAPH-OFFSET takes a mark and a number of paragraphs to
142 ;;; move over. If the specified number of paragraphs does not exist in
143 ;;; the direction indicated by the sign of number, then nil is
144 ;;; returned, otherwise the mark is returned.
145
146 (defun paragraph-offset (mark number &optional (prefix (value fill-prefix)))
147 "moves mark past the specified number of paragraph, forward if the number
148 is positive and vice versa. If the specified number of paragraphs do
149 not exist in the direction indicated by the sign of the number, then nil
150 is returned, otherwise the mark is returned."
151 (if (plusp number)
152 (%paragraph-offset-forward mark number prefix)
153 (%paragraph-offset-backward mark number prefix)))
154
155
156
157 ;;; %PARAGRAPH-OFFSET-FORWARD moves mark forward over number
158 ;;; paragraphs. The first branch of the COND is necessary for the side
159 ;;; effect provided by LINE-OFFSET. If %MARK-TO-PARAGRAPH left tmark at
160 ;;; the beginning of some paragraph %PARAGRAPH-OFFSET-AUX will think it has
161 ;;; moved mark past a paragraph, so we make sure tmark is inside the
162 ;;; paragraph or after it.
163
164 (defun %paragraph-offset-forward (mark number prefix)
165 (do* ((n number (1- n))
166 (tmark (line-start (copy-mark mark :temporary)))
167 (prefix-length (length prefix))
168 (paragraphp (%mark-to-paragraph tmark prefix prefix-length)
169 (if (plusp n)
170 (%mark-to-paragraph tmark prefix prefix-length))))
171 ((zerop n) (move-mark mark tmark))
172 (cond ((and paragraphp (not (line-offset tmark 1))) ;
173 (if (or (> n 1) (and (last-line-p mark) (end-line-p mark)))
174 (return nil))
175 (return (line-end (move-mark mark tmark))))
176 (paragraphp (%paragraph-offset-aux tmark prefix prefix-length))
177 (t (return nil)))))
178
179
180
181 (defun %paragraph-offset-backward (mark number prefix)
182 (with-mark ((tmark1 mark)
183 (tmark2 mark))
184 (do* ((n (abs number) (1- n))
185 (prefix-length (length prefix))
186 (paragraphp (%para-offset-back-find-para tmark1 prefix
187 prefix-length mark)
188 (if (plusp n)
189 (%para-offset-back-find-para tmark1 prefix
190 prefix-length tmark2))))
191 ((zerop n) (move-mark mark tmark1))
192 (cond ((and paragraphp (first-line-p tmark1))
193 (if (and (first-line-p mark) (start-line-p mark))
194 (return nil)
195 (if (> n 1) (return nil))))
196 (paragraphp
197 (%paragraph-offset-aux tmark1 prefix prefix-length :backward)
198 (%para-offset-back-place-mark tmark1 prefix prefix-length))
199 (t (return nil))))))
200
201
202
203 ;;; %PARA-OFFSET-BACK-PLACE-MARK makes sure that mark is in
204 ;;; the right place when it has been moved backward over a paragraph. The
205 ;;; "right place" is defined to be where EMACS leaves it for a given
206 ;;; situation or where it is necessary to ensure the mark's skipping
207 ;;; backward over another paragraph if PARAGRAPH-OFFSET was given an
208 ;;; argument with a greater magnitude than one. I believe these two
209 ;;; constraints are equivalent; that is, neither changes what the other
210 ;;; would dictate.
211
212 (defun %para-offset-back-place-mark (mark prefix prefix-length)
213 (skip-prefix-if-here mark prefix prefix-length)
214 (cond ((text-blank-line-p mark) (line-start mark))
215 ((not (first-line-p mark))
216 (line-offset mark -1 0)
217 (skip-prefix-if-here mark prefix prefix-length)
218 (if (text-blank-line-p mark)
219 (line-start mark)
220 (line-offset mark 1 0)))))
221
222
223
224 (defun %para-offset-back-find-para (mark1 prefix prefix-length mark2)
225 (move-mark mark2 mark1)
226 (line-start mark1)
227 (let ((para-p (%mark-to-paragraph mark1 prefix prefix-length :backward)))
228 (cond ((and para-p (same-line-p mark1 mark2))
229 (skip-prefix-if-here mark1 prefix prefix-length)
230 (find-attribute mark1 :whitespace #'zerop)
231 (cond ((mark<= mark2 mark1)
232 (line-offset mark1 -1 0)
233 (%mark-to-paragraph mark1 prefix prefix-length :backward))
234 (t (line-start mark1))))
235 (t para-p))))
236
237
238
239 ;;;; -- Sentence Commands --
240
241 (defcommand "Forward Sentence" (p)
242 "Moves forward one sentence or the specified number.
243 A sentence terminates with a .,?, or ! followed by any number of closing
244 delimiters (such as \",',),],>,|) which are followed by either two
245 spaces or a newline."
246 "Moves forward one sentence or the specified number."
247 (unless (sentence-offset (current-point) (or p 1))
248 (editor-error)))
249
250
251
252 (defcommand "Backward Sentence" (p)
253 "Moves backward one sentence or the specified number.
254 A sentence terminates with a .,?, or ! followed by any number of closing
255 delimiters (such as \",',),],>,|) which are followed by either two
256 spaces or a newline."
257 "Moves backward one sentence or the specified number."
258 (unless (sentence-offset (current-point) (- (or p 1)))
259 (editor-error)))
260
261
262
263 (defcommand "Mark Sentence" (p)
264 "Put mark and point around current or next sentence.
265 A sentence terminates with a .,?, or ! followed by any number of closing
266 delimiters (such as \",',),],>,|) which are followed by either two
267 spaces or a newline."
268 "Put mark and point around current or next sentence."
269 (declare (ignore p))
270 (let* ((point (current-point))
271 (end (copy-mark point :temporary)))
272 (unless (sentence-offset end 1) (editor-error))
273 (move-mark point end)
274 (sentence-offset point -1)
275 (push-buffer-mark end t)))
276
277
278 (defcommand "Forward Kill Sentence" (p)
279 "Kill forward to end of sentence."
280 "Kill forward to end of sentence."
281 (let ((point (current-point))
282 (offset (or p 1)))
283 (with-mark ((mark point))
284 (if (sentence-offset mark offset)
285 (if (plusp offset)
286 (kill-region (region point mark) :kill-forward)
287 (kill-region (region mark point) :kill-backward))
288 (editor-error)))))
289
290 (defcommand "Backward Kill Sentence" (p)
291 "Kill backward to beginning of sentence."
292 "Kill backward to beginning of sentence."
293 (forward-kill-sentence-command (- (or p 1))))
294
295 ;;; SENTENCE-OFFSET-END-P returns true if mark is at the end of a
296 ;;; sentence. If that the end of a sentence, it leaves mark at an
297 ;;; appropriate position with respect to the sentence-terminator character,
298 ;;; the beginning of the next sentence, and direction. See the commands
299 ;;; "Forward Sentence" and "Backward Sentence" for a definition of a sentence.
300
301 (eval-when (compile eval)
302 (defmacro sentence-offset-end-p (mark &optional (direction :forward))
303 `(let ((start (mark-charpos ,mark)))
304 (do ()
305 ((not (sentence-closing-char-attribute-p (next-character ,mark))))
306 (mark-after ,mark))
307 (let ((next (next-character ,mark)))
308 (cond ((or (not next)
309 (char= next #\newline))
310 ,(if (eq direction :forward) mark `(mark-after ,mark)))
311 ((and (char= next #\space)
312 (member (next-character (mark-after ,mark))
313 '(nil #\space #\newline)))
314 ,(if (eq direction :forward)
315 `(mark-before ,mark)
316 `(mark-after ,mark)))
317 (t (move-to-position ,mark start)
318 nil)))))
319 ); (eval-when (compile eval)
320
321
322
323 ;;; SENTENCE-OFFSET-FIND-END moves in the direction direction stopping
324 ;;; at sentence terminating characters until either there are not any more
325 ;;; such characters or one is found that defines the end of a sentence.
326 ;;; When looking backwards, we may be at the beginning of some sentence,
327 ;;; and if we are, then we must move mark before the sentence terminator;
328 ;;; otherwise, we would find the immediately preceding sentence terminator
329 ;;; and end up right where we started.
330
331 (eval-when (compile eval)
332 (defmacro sentence-offset-find-end (mark &optional (direction :forward))
333 `(progn
334 ,@(if (eq direction :backward)
335 `((reverse-find-attribute ,mark :whitespace #'zerop)
336 (when (fill-region-insert-two-spaces-p ,mark)
337 (reverse-find-attribute ,mark :sentence-terminator)
338 (mark-before ,mark))))
339 (do ((foundp) (endp)) (nil)
340 (setf foundp ,(if (eq direction :forward)
341 `(find-attribute ,mark :sentence-terminator)
342 `(reverse-find-attribute ,mark :sentence-terminator)))
343 (setf endp ,(if (eq direction :forward)
344 `(if foundp (progn (mark-after ,mark)
345 (sentence-offset-end-p ,mark)))
346 `(if foundp (sentence-offset-end-p ,mark :backward))))
347 (if endp (return ,mark))
348 ,(if (eq direction :forward)
349 `(unless foundp (return nil))
350 `(if foundp (mark-before ,mark) (return nil))))))
351 ); (eval-when (compile eval)
352
353
354
355 ;;; SENTENCE-OFFSET takes a mark and a number of paragraphs to move
356 ;;; over. If the specified number of paragraphs does not exist in
357 ;;; the direction indicated by the sign of the number, then nil is returned,
358 ;;; otherwise the mark is returned.
359
360 (defun sentence-offset (mark number)
361 (if (plusp number)
362 (sentence-offset-forward mark number)
363 (sentence-offset-backward mark (abs number))))
364
365
366
367 ;;; SENTENCE-OFFSET-FORWARD tries to move mark forward over number
368 ;;; sentences. If it can, then mark is moved and returned; otherwise, mark
369 ;;; remains unmoved, and nil is returned. When tmark2 is moved to the end
370 ;;; of a new paragraph, we reverse find for a non-whitespace character to
371 ;;; bring tmark2 to the end of the previous line. This is necessary to
372 ;;; detect if tmark1 is at the end of the paragraph, in which case tmark2
373 ;;; wants to be moved over another paragraph.
374
375 (defun sentence-offset-forward (mark number)
376 (with-mark ((tmark1 mark)
377 (tmark2 mark))
378 (do ((n number (1- n))
379 (found-paragraph-p))
380 ((zerop n) (move-mark mark tmark1))
381 (when (and (mark<= tmark2 tmark1)
382 (setf found-paragraph-p (paragraph-offset tmark2 1)))
383 (reverse-find-attribute tmark2 :whitespace #'zerop)
384 (when (mark>= tmark1 tmark2)
385 (line-offset tmark2 1 0)
386 (setf found-paragraph-p (paragraph-offset tmark2 1))
387 (reverse-find-attribute tmark2 :whitespace #'zerop)))
388 (cond ((sentence-offset-find-end tmark1)
389 (if (mark> tmark1 tmark2) (move-mark tmark1 tmark2)))
390 (found-paragraph-p (move-mark tmark1 tmark2))
391 (t (return nil))))))
392
393
394
395 (defun sentence-offset-backward (mark number)
396 (with-mark ((tmark1 mark)
397 (tmark2 mark)
398 (tmark3 mark))
399 (do* ((n number (1- n))
400 (prefix (value fill-prefix))
401 (prefix-length (length prefix))
402 (found-paragraph-p
403 (cond ((paragraph-offset tmark2 -1)
404 (sent-back-place-para-start tmark2 prefix prefix-length)
405 t))))
406 ((zerop n) (move-mark mark tmark1))
407 (move-mark tmark3 tmark1)
408 (when (and (sent-back-para-start-p tmark1 tmark3 prefix prefix-length)
409 (setf found-paragraph-p
410 (paragraph-offset (move-mark tmark2 tmark3) -1)))
411 (paragraph-offset (move-mark tmark1 tmark2) 1)
412 (sent-back-place-para-start tmark2 prefix prefix-length))
413 (cond ((sentence-offset-find-end tmark1 :backward)
414 (if (mark< tmark1 tmark2) (move-mark tmark1 tmark2)))
415 (found-paragraph-p (move-mark tmark1 tmark2))
416 (t (return nil))))))
417
418
419
420 (defun sent-back-para-start-p (mark1 mark2 prefix prefix-length)
421 (skip-prefix-if-here (line-start mark2) prefix prefix-length)
422 (cond ((text-blank-line-p mark2)
423 (line-start mark2))
424 ((whitespace-attribute-p (next-character mark2))
425 (find-attribute mark2 :whitespace #'zerop)
426 (if (mark= mark1 mark2) (line-offset mark2 -1 0)))
427 ((and (mark= mark2 mark1) (line-offset mark2 -1 0))
428 (skip-prefix-if-here mark2 prefix prefix-length)
429 (if (text-blank-line-p mark2)
430 (line-start mark2)))))
431
432
433
434 (defun sent-back-place-para-start (mark2 prefix prefix-length)
435 (skip-prefix-if-here mark2 prefix prefix-length)
436 (when (text-blank-line-p mark2)
437 (line-offset mark2 1 0)
438 (skip-prefix-if-here mark2 prefix prefix-length))
439 (find-attribute mark2 :whitespace #'zerop))
440
441
442
443 ;;;; -- Transposing Stuff --
444
445 (defcommand "Transpose Words" (p)
446 "Transpose the words before and after the cursor.
447 With a positive argument it transposes the words before and after the
448 cursor, moves right, and repeats the specified number of times,
449 dragging the word to the left of the cursor right. With a negative
450 argument, it transposes the two words to the left of the cursor, moves
451 between them, and repeats the specified number of times, exactly undoing
452 the positive argument form."
453 "Transpose the words before and after the cursor."
454 (let ((num (or p 1))
455 (point (current-point)))
456 (with-mark ((mark point :left-inserting)
457 (start point :left-inserting))
458 (let ((mark-prev (previous-character mark))
459 (mark-next (next-character mark)))
460 (cond ((plusp num)
461 (let ((forwardp (word-offset point num))
462 (backwardp (if (or (word-delimiter-attribute-p mark-next)
463 (word-delimiter-attribute-p mark-prev))
464 (word-offset mark -1)
465 (word-offset mark -2))))
466 (if (and forwardp backwardp)
467 (transpose-words-forward mark point start)
468 (editor-error))))
469 ((minusp num)
470 (let ((enoughp (word-offset point (1- num))))
471 (if (word-delimiter-attribute-p mark-prev)
472 (reverse-find-attribute mark :word-delimiter #'zerop)
473 (find-attribute mark :word-delimiter))
474 (if enoughp
475 (transpose-words-backward point mark start)
476 (editor-error))))
477 (t (editor-error)))))))
478
479
480 (defun transpose-words-forward (mark1 end mark2)
481 (with-mark ((tmark1 mark1 :left-inserting)
482 (tmark2 mark2 :left-inserting))
483 (find-attribute tmark1 :word-delimiter)
484 (do ((region1 (delete-and-save-region (region mark1 tmark1))))
485 ((mark= tmark2 end) (ninsert-region end region1))
486 (word-offset tmark2 1)
487 (reverse-find-attribute (move-mark tmark1 tmark2) :word-delimiter)
488 (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2)))
489 (move-mark mark1 tmark1))))
490
491
492 (defun transpose-words-backward (start mark1 mark2)
493 (with-mark ((tmark1 mark1 :left-inserting)
494 (tmark2 mark2 :left-inserting))
495 (reverse-find-attribute tmark1 :word-delimiter)
496 (move-mark mark2 mark1)
497 (do ((region1 (delete-and-save-region (region tmark1 mark1))))
498 ((mark= tmark1 start) (ninsert-region start region1))
499 (word-offset tmark1 -1)
500 (find-attribute (move-mark tmark2 tmark1) :word-delimiter)
501 (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2)))
502 (move-mark mark1 tmark1))))
503
504 (defcommand "Transpose Lines" (p)
505 "Transpose the current line with the line before the cursor.
506 With a positive argument it transposes the current line with the one
507 before, moves down a line, and repeats the specified number of times,
508 dragging the originally current line down. With a negative argument, it
509 transposes the two lines to the prior to the current, moves up a line,
510 and repeats the specified number of times, exactly undoing the positive
511 argument form. With a zero argument, it transposes the lines at point
512 and mark."
513 "Transpose the current line with the line before the cursor."
514 (let ((num (or p 1))
515 (point (current-point)))
516 (with-mark ((mark point :left-inserting))
517 (cond ((plusp num)
518 (if (and (line-offset mark -1 0)
519 (line-offset point num 0))
520 (transpose-lines mark point)
521 (editor-error)))
522 ((minusp num)
523 (cond ((and (line-offset mark (1- num) 0)
524 (line-offset point -1 0))
525 (transpose-lines point mark)
526 (move-mark point mark))
527 (t (editor-error))))
528 (t
529 (rotatef (line-string (mark-line point))
530 (line-string (mark-line (current-mark))))
531 (line-start point))))))
532
533
534 (defun transpose-lines (mark1 mark2)
535 (with-mark ((tmark1 mark1))
536 (line-offset tmark1 1)
537 (ninsert-region mark2 (delete-and-save-region (region mark1 tmark1)))))
538
539
540
541 ;;;; -- Utilities --
542
543 (defun skip-prefix-if-here (mark prefix prefix-length)
544 (if (and prefix (%line-has-prefix-p mark prefix prefix-length))
545 (character-offset mark prefix-length)))
546
547
548
549 (defun text-blank-line-p (mark)
550 (let ((next-char (next-character mark)))
551 (or (blank-after-p mark)
552 (and (funcall (value paragraph-delimiter-function) mark)
553 (not (whitespace-attribute-p next-char))))))
554
555
556
557 (defun whitespace-attribute-p (char)
558 (= (character-attribute :whitespace char) 1))
559
560 (defun sentence-terminator-attribute-p (char)
561 (= (character-attribute :sentence-terminator char) 1))
562
563 (defun sentence-closing-char-attribute-p (char)
564 (= (character-attribute :sentence-closing-char char) 1))
565
566 (defun paragraph-delimiter-attribute-p (char)
567 (= (character-attribute :paragraph-delimiter char) 1))
568
569 (defun word-delimiter-attribute-p (char)
570 (= (character-attribute :word-delimiter char) 1))

  ViewVC Help
Powered by ViewVC 1.1.5