Mercurial > hg > xemacs-beta

comparison lisp/mule/visual-mode.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children 360340f9fd5f
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;; visual.el -- cursor motion, insertion, deletion, etc. in visual order
2 ;; Copyright (C) 1992 Free Software Foundation, Inc.
3
4 ;; This file is part of XEmacs.
5
6 ;; XEmacs is free software; you can redistribute it and/or modify it
7 ;; under the terms of the GNU General Public License as published by
8 ;; the Free Software Foundation; either version 2, or (at your option)
9 ;; any later version.
10
11 ;; XEmacs is distributed in the hope that it will be useful, but
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;; General Public License for more details.
15
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with XEmacs; see the file COPYING. If not, write to the
18 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;; Boston, MA 02111-1307, USA.
20
21 ;;; 94.5.15 created for Mule Ver.1.1 by Takahashi N. <ntakahas@etl.go.jp>
22
23 ;;;###autoload
24 (defvar visual-mode nil "non-nil if in visual-mode.")
25
26 (make-variable-buffer-local 'visual-mode)
27
28 (defvar visual-use-lr-commands nil
29 "If non-nil, use visual-left-* and visual-right-* commands instead of
30 visual-forward-* and visual-backward-* commands.")
31
32 (defvar visual-mode-map
33 (let ((map (make-keymap)))
34 (substitute-key-definition 'self-insert-command
35 'visual-self-insert-command
36 map global-map)
37 ; visual basic commands
38 (define-key map [(control d)] 'visual-delete-char)
39 (define-key map [(control k)] 'visual-kill-line)
40 (define-key map [(control m)] 'visual-newline)
41 (define-key map [(control o)] 'visual-open-line)
42 (define-key map [(control p)] 'visual-previous-line)
43 (define-key map [(control w)] 'visual-kill-region)
44 (define-key map [(control y)] 'visual-yank)
45 (define-key map [delete] 'visual-backward-delete-char)
46 (define-key map [(meta <)] 'visual-beginning-of-buffer)
47 (define-key map [(meta >)] 'visual-end-of-buffer)
48 (define-key map [(meta d)] 'visual-kill-word)
49 (define-key map [(meta w)] 'visual-kill-ring-save)
50 (define-key map [(meta y)] 'visual-yank-pop)
51 (define-key map [(meta delete)] 'visual-backward-kill-word)
52 (define-key map [up] 'visual-previous-line)
53 (define-key map [down] 'visual-next-line)
54 (define-key map [home] 'visual-beginning-of-buffer)
55 (define-key map [end] 'visual-end-of-buffer)
56 (define-key map [left] 'visual-move-to-left-char)
57 (define-key map [right] 'visual-move-to-right-char)
58 (define-key map [(meta left)] 'visual-move-to-left-word)
59 (define-key map [(meta right)] 'visual-move-to-right-word)
60 (define-key map [(control c) (control c)] 'exit-visual-mode)
61 (define-key map [(control c) <] 'l2r-mode)
62 (define-key map [(control c) >] 'r2l-mode)
63 ; LR commands
64 (if visual-use-lr-commands
65 (progn
66 (define-key map [(control a)] 'visual-left-end-of-line)
67 (define-key map [(control b)] 'visual-move-to-left-char)
68 (define-key map [(control e)] 'visual-right-end-of-line)
69 (define-key map [(control f)] 'visual-move-to-right-char)
70 (define-key map [(meta b)] 'visual-move-to-left-word)
71 (define-key map [(meta f)] 'visual-move-to-right-word))
72 (define-key map [(control a)] 'visual-beginning-of-line)
73 (define-key map [(control b)] 'visual-backward-char)
74 (define-key map [(control e)] 'visual-end-of-line)
75 (define-key map [(control f)] 'visual-forward-char)
76 (define-key map [(meta b)] 'visual-backward-word)
77 (define-key map [(meta f)] 'visual-forward-word))
78 map)
79 "minor-mode-keymap for visual-mode.")
80
81 (if (not (assq 'visual-mode minor-mode-map-alist))
82 (setq minor-mode-map-alist
83 (cons (cons 'visual-mode visual-mode-map)
84 minor-mode-map-alist)))
85
86 (defvar visual-mode-indicator nil
87 "string displayed in mode line. \" l2r\" or \" r2l\".")
88 (make-variable-buffer-local 'visual-mode-indicator)
89
90 (if (not (assq 'visual-mode minor-mode-alist))
91 (setq minor-mode-alist
92 (cons '(visual-mode visual-mode-indicator)
93 minor-mode-alist)))
94
95 (setq auto-mode-alist
96 (append '(("\\.l2r$" . l2r-mode) ("\\.r2l$" . r2l-mode))
97 auto-mode-alist))
98
99 (defvar visual-mode-hooks nil)
100
101 ;;;###autoload
102 (defun visual-mode (&optional arg)
103 "Toggle visual-mode. With ARG, turn visual-mode on iff ARG is positive."
104 (interactive "P")
105 (if (null arg)
106 (if visual-mode (exit-visual-mode) (enter-visual-mode))
107 (if (> (prefix-numeric-value arg) 0)
108 (enter-visual-mode)
109 (exit-visual-mode))))
110
111 (defun enter-visual-mode nil
112 "Enter visual-mode. Cursor moves in visual order."
113 (interactive)
114 (if (not visual-mode)
115 (progn
116 (setq visual-mode t
117 visual-mode-indicator (if display-direction " r2l" " l2r"))
118 (redraw-display)
119 (run-hooks 'visual-mode-hooks))))
120
121 (defun exit-visual-mode nil
122 "Exit visual-mode. Cursor moves in logical order."
123 (interactive)
124 (if visual-mode
125 (progn
126 (setq visual-mode nil)
127 (redraw-modeline t))))
128
129 (defun l2r-mode nil
130 "Set display-direction left to right."
131 (interactive)
132 (if (not visual-mode)
133 (enter-visual-mode))
134 (setq display-direction nil)
135 (setq visual-mode-indicator " l2r")
136 (redraw-display))
137
138 (defun r2l-mode nil
139 "Set display-direction right to left."
140 (interactive)
141 (if (not visual-mode)
142 (enter-visual-mode))
143 (setq display-direction t)
144 (setq visual-mode-indicator " r2l")
145 (redraw-display))
146
147
148 ;; cursor motion
149
150 (defun visual-forward-char (arg)
151 "Move the cursor visually forward by ARG (integer) characters.
152 if ARG is negative, move backward."
153 (interactive "p")
154 (if (< arg 0)
155 (while (< arg 0)
156 (visual-backward-1-char)
157 (setq arg (1+ arg)))
158 (while (> arg 0)
159 (visual-forward-1-char)
160 (setq arg (1- arg)))))
161
162 (defun visual-forward-1-char nil
163 "Move the cursor visually forward by 1 character."
164 (let ((r-dir (if display-direction 0 1))
165 (a-dir (visual-char-direction-after-point))
166 (aa-dir (visual-char-direction-after-after-point))
167 (b-dir (visual-char-direction-before-point)))
168
169 ; symbols used in the following comments
170 ; ^ : point in here
171 ; ~ : point will be there
172 ; d : character whose direction is the same as display-direction
173 ; r : character whose direction is opposite to display-direction
174 ; !d : r or nil
175 ; !r : d or nil
176 ; r* : 0 or more r's
177 ; d* : 0 or more d's
178
179 (cond
180 ((null a-dir)
181 ; ... nil
182 ; ^
183 (error "end of buffer"))
184
185 ((eq a-dir r-dir)
186 (if (eq b-dir r-dir)
187
188 ; ... r r ...
189 ; ~ ^
190 (backward-char 1)
191
192 ; ... !r r r* ...
193 ; ^ ~
194 (skip-direction-forward r-dir)))
195
196 ((eq aa-dir r-dir)
197 ; ... d r* r ...
198 ; ^ ~
199 (forward-char 1)
200 (skip-direction-forward r-dir)
201 (backward-char 1))
202
203 (t
204 ; ... d !r ...
205 ; ^ ~
206 (forward-char 1)))))
207
208 (defun visual-backward-char (arg)
209 "Move the cursor visually backward by ARG (integer) characters.
210 if ARG is negative, move forward."
211 (interactive "p")
212 (if (< arg 0)
213 (while (< arg 0)
214 (visual-forward-1-char)
215 (setq arg (1+ arg)))
216 (while (> arg 0)
217 (visual-backward-1-char)
218 (setq arg (1- arg)))))
219
220 (defun visual-backward-1-char nil
221 "Move the cursor visually backward by 1 character."
222 (let ((r-dir (if display-direction 0 1))
223 (a-dir (visual-char-direction-after-point))
224 (aa-dir (visual-char-direction-after-after-point))
225 (b-dir (visual-char-direction-before-point)))
226
227 ; symbols used in the following comments
228 ; ^ : point in here
229 ; ~ : point will be there
230 ; d : character whose direction is the same as display-direction
231 ; r : character whose direction is opposite to display-direction
232 ; !d : r or nil
233 ; !r : d or nil
234 ; r* : 0 or more r's
235 ; d* : 0 or more d's
236
237 (cond
238 ((eq a-dir r-dir)
239 (if (eq aa-dir r-dir)
240 ; ... r r ...
241 ; ^ ~
242 (forward-char 1)
243
244 ; ... !r r* !r ...
245 ; ~ ^
246 (skip-direction-backward r-dir)
247 (if (visual-char-direction-before-point)
248 (backward-char 1)
249 (skip-direction-forward r-dir)
250 (backward-char 1)
251 (error "beginning of buffer"))))
252
253 ((null b-dir)
254 ; nil !r ...
255 ; ^
256 (error "beginning of buffer"))
257
258 ((eq b-dir r-dir)
259 ; ... r* r !r
260 ; ~ ^
261 (skip-direction-backward r-dir))
262
263 (t
264 ; ... d !r ...
265 ; ~ ^
266 (backward-char 1)))))
267
268 (defun visual-char-direction (ch)
269 "Return the direction of CH (character).
270 Newline's direction will be same as display-direction."
271 (cond
272 ((null ch) nil)
273 ((= ch ?\n) (if display-direction 1 0))
274 (t (char-direction ch))))
275
276 (defun visual-char-direction-after-point nil
277 "Return the direction of after-point-character.
278 0: left-to-right, 1: right-to-left"
279 (visual-char-direction (char-after (point))))
280
281 (defun visual-char-direction-after-after-point nil
282 "Return the direction of after-after-point-character.
283 0: left-to-right, 1: right-to-left"
284 (if (= (point) (point-max))
285 nil
286 (save-excursion
287 (forward-char 1)
288 (visual-char-direction (char-after (point))))))
289
290 (defun visual-char-direction-before-point nil
291 "Return the direction of before-point-character.
292 0: left-to-right, 1: right-to-left"
293 (visual-char-direction (char-before (point))))
294
295 (defun skip-direction-forward (dir)
296 "Move point forward as long as DIR-direction characters continue."
297 (while (eq (visual-char-direction-after-point) dir)
298 (forward-char 1)))
299
300 (defun skip-direction-backward (dir)
301 "Move point backward as long as DIR-direction characters continue."
302 (while (eq (visual-char-direction-before-point) dir)
303 (backward-char 1)))
304
305 (defvar *visual-punctuations*
306 '(? ?. ?, ?: ?; ?? ?! ?- ?_ ?' ?\" ?/ ?( ?) ?[ ?] ?{ ?} ?\n ?\t ; ASCII
307 ? ?. ?, ?: ?; ?? ?! ?- ?_ ?' ?" ?( ?) ?[ ?] ; Hebrew
308 ?[2](3![0](B ?[2](3&[0](B ?[2](3%[0](B ?[2](3)[0](B ?[2](3"[0](B ?[2](3'[0](B ?[2](3([0](B ?[2](3#[0](B ?[2](3$[0](B ?[2](3*[0](B ?[2](3+[0](B )) ; Arabic
309
310 (defun visual-forward-word (arg)
311 "Move the cursor visually forward by ARG (integer) words.
312 If ARG is negative, move the cursor backward."
313 (interactive "p")
314 (if (< arg 0)
315 (while (< arg 0)
316 (visual-backward-1-word)
317 (setq arg (1+ arg)))
318 (while (> arg 0)
319 (visual-forward-1-word)
320 (setq arg (1- arg)))))
321
322 (defun visual-backward-word (arg)
323 "Move the cursor visually backward by ARG (integer) words.
324 If ARG is negative, move the cursor forward."
325 (interactive "p")
326 (if (< arg 0)
327 (while (< arg 0)
328 (visual-forward-1-word)
329 (setq arg (1+ arg)))
330 (while (> arg 0)
331 (visual-backward-1-word)
332 (setq arg (1- arg)))))
333
334 (defun visual-forward-1-word nil
335 "Move the cursor visually forward by one word."
336 (while (memq (visual-char-after) *visual-punctuations*)
337 (visual-forward-1-char))
338 (while (not (memq (visual-char-after) *visual-punctuations*))
339 (visual-forward-1-char)))
340
341 (defun visual-backward-1-word nil
342 "Move the cursor visually backward by one word."
343 (while (memq (visual-char-before) *visual-punctuations*)
344 (visual-backward-1-char))
345 (while (not (memq (visual-char-before) *visual-punctuations*))
346 (visual-backward-1-char)))
347
348 (defun visual-char-before nil
349 "Return the character visually before the cursor.
350 If such position is out of range, returns nil."
351 ; almost same as visual-backward-1-char
352 (save-excursion
353 (let ((r-dir (if display-direction 0 1))
354 (a-dir (visual-char-direction-after-point))
355 (aa-dir (visual-char-direction-after-after-point))
356 (b-dir (visual-char-direction-before-point)))
357 (cond
358 ((eq a-dir r-dir)
359 (if (eq aa-dir r-dir)
360 (progn
361 (forward-char 1)
362 (char-after (point)))
363 (skip-direction-backward r-dir)
364 (if (visual-char-direction-before-point)
365 (progn
366 (backward-char 1)
367 (char-after (point)))
368 nil)))
369 ((null b-dir)
370 nil)
371 ((eq b-dir r-dir)
372 (skip-direction-backward r-dir)
373 (char-after (point)))
374 (t
375 (backward-char 1)
376 (char-after (point)))))))
377
378 (defun visual-char-after nil
379 "Return the character under the cursor.
380 If such position is out of range, returns nil."
381 (char-after (point)))
382
383 (defun visual-beginning-of-line (&optional arg)
384 "Move the cursor to the visual beginning of line.
385 With ARG not nil, move forward ARG - 1 lines first.
386 If scan reaches end of buffer, stop there without error."
387 (interactive "P")
388 (beginning-of-line arg)
389 (let ((a-dir (visual-char-direction-after-point))
390 (d-dir (if display-direction 1 0)))
391 (if (and a-dir (/= a-dir d-dir))
392 (progn (skip-direction-forward a-dir)
393 (backward-char 1)))))
394
395 (fset 'visual-end-of-line 'end-of-line)
396
397 (defun visual-beginning-of-buffer nil
398 "Move the cursor to the visual beginning of current buffer."
399 (interactive)
400 (beginning-of-buffer)
401 (visual-beginning-of-line))
402
403 (fset 'visual-end-of-buffer 'end-of-buffer)
404
405 (defvar visual-temporary-goal-column 0
406 "temporary-goal-column command for visual-mode.")
407
408 (defun visual-next-line (arg)
409 "next-line command for visual-mode."
410 (interactive "p")
411 (if (and (not (eq last-command 'visual-next-line))
412 (not (eq last-command 'visual-previous-line)))
413 (setq visual-temporary-goal-column (visual-current-column)))
414 (next-line arg)
415 (visual-goto-column visual-temporary-goal-column))
416
417 (defun visual-previous-line (arg)
418 "previous-line command for visual-mode."
419 (interactive "p")
420 (if (and (not (eq last-command 'visual-next-line))
421 (not (eq last-command 'visual-previous-line)))
422 (setq visual-temporary-goal-column (visual-current-column)))
423 (previous-line arg)
424 (visual-goto-column visual-temporary-goal-column))
425
426 (defun visual-current-column nil
427 "Return the current column counted in visual order."
428 (let ((c 0) (p (point)))
429 (visual-beginning-of-line)
430 (while (/= (point) p)
431 (setq c (+ c (char-width (visual-char-after))))
432 (visual-forward-1-char))
433 c))
434
435 (defun visual-goto-column (col)
436 "Move the cursor to visual column N (integer) in the current line.
437 If it is impossible to go to column N, the cursor is put on the nearest column
438 M (M < N). Returns N - M."
439 (if (< col 0)
440 (error "argument must be positive."))
441 (let ((c 0))
442 (visual-beginning-of-line)
443 (while (and (< c col) (not (eolp)))
444 (setq c (+ c (char-width (visual-char-after))))
445 (visual-forward-1-char))
446 (if (> c col)
447 (progn
448 (visual-backward-1-char)
449 (setq c (- c (char-width (visual-char-after))))))
450 (- col c)))
451
452
453 ;; insertion
454
455 (defun visual-insert-char (ch arg)
456 "Insert character CH visually before the cursor.
457 With ARG (integer) insert that many characters."
458 (if (< arg 0)
459 (error "arg must be >= 0."))
460 (while (> arg 0)
461 (visual-insert-1-char ch)
462 (setq arg (1- arg))))
463
464 (defun visual-insert-1-char (ch)
465 "Insert character CH visually before the cursor.
466 The cursor moves visually forward."
467 (let ((c-dir (visual-char-direction ch))
468 (r-dir (if display-direction 0 1))
469 (a-dir (visual-char-direction-after-point))
470 (tmp))
471
472 ; symbols used in the following comments
473 ; d : character whose direction is the same as display-direction
474 ; r : character whose direction is opposite to display-direction
475 ; !d : r or nil
476 ; !r : d or nil
477 ; ^d : point is here and the character to be inserted is d
478 ; ^r : point is here and the character to be inserted is d
479
480 (if (eq c-dir r-dir)
481 (if (eq a-dir r-dir)
482
483 ; ... r ...
484 ; ^r
485 (progn
486 (forward-char 1)
487 (insert ch)
488 (backward-char 2))
489
490 ; ... !r ...
491 ; ^r
492 (skip-direction-backward c-dir)
493 (insert ch)
494 (skip-direction-forward c-dir))
495
496 (if (or (eq a-dir nil)
497 (eq a-dir c-dir))
498
499 ; ... !r ...
500 ; ^d
501 (insert ch)
502
503 ; ... r ...
504 ; ^d
505 (forward-char 1)
506 (setq tmp (delete-direction-backward r-dir))
507 (skip-direction-forward r-dir)
508 (insert ch tmp)
509 (backward-char 1)))))
510
511 (defun delete-direction-forward (dir)
512 "From current point, delete DIR-direction charaters forward.
513 Returns the deleted string."
514 (let ((p (point)))
515 (skip-direction-forward dir)
516 (prog1
517 (buffer-substring (point) p)
518 (delete-region (point) p))))
519
520 (defun delete-direction-backward (dir)
521 "From current point, delete DIR-direction characters backward.
522 Return the deleted string."
523 (let ((p (point)))
524 (skip-direction-backward dir)
525 (prog1
526 (buffer-substring (point) p)
527 (delete-region (point) p))))
528
529 (defun visual-self-insert-command (arg)
530 "Insert this character (32 <= CH < 127).
531 With ARG (integer), insert that many characters.
532 If display-direction is non-nil, the cursor stays at the same position."
533 (interactive "*p")
534 (visual-insert-char last-command-char arg)
535 (if display-direction
536 (visual-backward-char arg)))
537
538 (defun visual-newline (arg)
539 "newline command for visual-mode.
540 With ARG (integer), insert that many newlines."
541 (interactive "*p")
542 (visual-insert-char ?\n arg))
543
544 (defun visual-open-line (arg)
545 "open-line command for visual-mode.
546 With arg (integer), insert that many newlines."
547 (interactive "*p")
548 (visual-insert-char ?\n arg)
549 (visual-backward-char arg))
550
551
552 ;; deletion
553
554 (defun visual-delete-char (arg)
555 "Delete ARG (integer) characters visually forward.
556 If ARG is negative, delete backward."
557 (interactive "*p")
558 (if (< arg 0)
559 (while (< arg 0)
560 (visual-backward-delete-1-char)
561 (setq arg (1+ arg)))
562 (while (> arg 0)
563 (visual-delete-1-char)
564 (setq arg (1- arg)))))
565
566 (defun visual-backward-delete-char (arg)
567 "Delete ARG (integer) characters visually backward.
568 If arg is negative, delete forward."
569 (interactive "*p")
570 (if (< arg 0)
571 (while (< arg 0)
572 (visual-delete-1-char)
573 (setq arg (1+ arg)))
574 (while (> arg 0)
575 (visual-backward-delete-1-char)
576 (setq arg (1- arg)))))
577
578 (fset 'visual-delete-backward-char 'visual-backward-delete-char)
579
580 (defun visual-backward-delete-1-char nil
581 "Delete a character visually before the cursor.
582 Ther cursor moves visually backward."
583 (let ((d-dir (if display-direction 1 0))
584 (r-dir (if display-direction 0 1))
585 (a-dir (visual-char-direction-after-point))
586 (aa-dir (visual-char-direction-after-after-point))
587 (b-dir (visual-char-direction-before-point))
588 (tmp))
589
590 ; symbols used in the following comments
591 ; ^ : point in here
592 ; d : character whose direction is the same as display-direction
593 ; r : character whose direction is opposite to display-direction
594 ; !d : r or nil
595 ; !r : d or nil
596 ; r* : 0 or more r's
597 ; d* : 0 or more d's
598
599 (if (eq a-dir r-dir)
600 (cond
601 ((eq aa-dir r-dir)
602 ; ... r r ...
603 ; ^
604 (forward-char 1)
605 (delete-char 1)
606 (backward-char 1))
607
608 ((save-excursion
609 (skip-direction-backward r-dir)
610 (backward-char 1)
611 (and (eq (visual-char-direction-after-point) d-dir)
612 (eq (visual-char-direction-before-point) r-dir)))
613 ; ... r d r* r !r ...
614 ; ^
615 (forward-char 1)
616 (setq tmp (delete-direction-backward r-dir))
617 (delete-backward-char 1)
618 (skip-direction-backward r-dir)
619 (insert tmp)
620 (backward-char 1))
621
622 (t
623 ; .....!r d r* r !r ...
624 ; ^
625 (skip-direction-backward r-dir)
626 (delete-backward-char 1)
627 (skip-direction-forward r-dir)
628 (backward-char 1)))
629
630 (cond
631 ((null b-dir)
632 ; nil !r ...
633 ; ^
634 (error "beginning of buffer"))
635
636 ((eq b-dir r-dir)
637 ; ... r !r ...
638 ; ^
639 (skip-direction-backward r-dir)
640 (delete-char 1)
641 (skip-direction-forward r-dir))
642
643 (t
644 ; ... !r !r ...
645 ; ^
646 (delete-backward-char 1))))))
647
648 (fset 'visual-delete-backward-1-char 'visual-backward-delete-1-char)
649
650 (defun visual-delete-1-char nil
651 "Delete a character under the cursor.
652 Visually, the cursor stays at the same position."
653 (let ((d-dir (if display-direction 1 0))
654 (r-dir (if display-direction 0 1))
655 (a-dir (visual-char-direction-after-point))
656 (aa-dir (visual-char-direction-after-after-point))
657 (b-dir (visual-char-direction-before-point))
658 (tmp))
659
660 ; symbols used in the following comments
661 ; ^ : point in here
662 ; d : character whose direction is the same as display-direction
663 ; r : character whose direction is opposite to display-direction
664 ; !d : r or nil
665 ; !r : d or nil
666 ; r* : 0 or more r's
667 ; d* : 0 or more d's
668
669 (cond
670 ((null a-dir)
671 ; ... nil
672 ; ^
673 (error "end of buffer"))
674
675 ((eq a-dir r-dir)
676 (if (eq b-dir r-dir)
677
678 ; ... r r ...
679 ; ^
680 (progn (delete-char 1)
681 (backward-char 1))
682
683 ; ... !r r ...
684 ; ^
685 (delete-char 1)
686 (skip-direction-forward r-dir)))
687
688 ((not (eq aa-dir r-dir))
689 ; ... d !r ...
690 ; ^
691 (delete-char 1))
692
693 ((eq b-dir r-dir)
694 ; ... r d r ...
695 ; ^
696 (delete-char 1)
697 (setq tmp (delete-direction-forward r-dir))
698 (skip-direction-backward r-dir)
699 (insert tmp)
700 (backward-char 1))
701
702 (t
703 ; ...!r d r ...
704 ; ^
705 (delete-char 1)
706 (skip-direction-forward r-dir)
707 (backward-char 1)))))
708
709 (defun visual-delete-region (beg end)
710 "delete-region command for visual-mode."
711 (interactive "*r")
712 (let ((begl) (begc) (endl) (endc) (l))
713
714 ; swap beg & end if necessary
715 (goto-char beg)
716 (setq begl (current-line)
717 begc (visual-current-column))
718 (goto-char end)
719 (setq endl (current-line)
720 endc (visual-current-column))
721 (if (or (> begl endl)
722 (and (= begl endl)
723 (> begc endc)))
724 (progn
725 (setq beg (prog1 end (setq end beg))
726 begl (prog1 endl (setq endl begl))
727 begc (prog1 endc (setq endc begc)))
728 (goto-char end)))
729
730 ; insert a newline visually at END
731 (visual-insert-1-char ?\n)
732 (visual-backward-1-char)
733 (setq l (current-line))
734
735 ; insert a newline visually at BEG
736 (goto-line begl)
737 (visual-goto-column begc)
738 (visual-insert-1-char ?\n)
739 (beginning-of-line)
740
741 (delete-region
742 (point)
743 (progn
744 (goto-line (1+ l))
745 (end-of-line)
746 (point)))
747 (backward-char 1)
748 (visual-delete-char 2)))
749
750 (defun current-line nil
751 "Return the current line number (in the buffer) of point."
752 (interactive)
753 (save-excursion
754 (beginning-of-line)
755 (1+ (count-lines 1 (point)))))
756
757
758 ;; kill
759
760 (defun visual-kill-region (beg end)
761 "kill-region command for visual-mode."
762 (interactive "r")
763 (let ((begl) (begc) (endl) (endc) (l))
764
765 ; swap beg & end if necessary
766 (goto-char beg)
767 (setq begl (current-line)
768 begc (visual-current-column))
769 (goto-char end)
770 (setq endl (current-line)
771 endc (visual-current-column))
772 (if (or (> begl endl)
773 (and (= begl endl) (> begc endc)))
774 (progn
775 (setq beg (prog1 end (setq end beg))
776 begl (prog1 endl (setq endl begl))
777 begc (prog1 endc (setq endc begc)))
778 (goto-char end)))
779
780 (if (or (and buffer-read-only (not inhibit-read-only))
781 (text-property-not-all beg end 'read-only nil))
782 (progn
783 (visual-copy-region-as-kill beg end)
784 (if kill-read-only-ok
785 (message "Read only text copied to kill ring")
786 (barf-if-buffer-read-only)))
787
788 ; insert a newline visually at END
789 (visual-insert-1-char ?\n)
790 (visual-backward-1-char)
791 (setq l (current-line))
792
793 ; insert a newline visually at BEG
794 (goto-line begl)
795 (visual-goto-column begc)
796 (visual-insert-1-char ?\n)
797 (beginning-of-line)
798
799 (kill-region
800 (point)
801 (progn
802 (goto-line (1+ l))
803 (end-of-line)
804 (point)))
805 (backward-char 1)
806 (visual-delete-char 2)))
807
808 (setq this-command 'kill-region))
809
810 (defun visual-kill-word (arg)
811 "Kill ARG (integer) words visually forward.
812 If ARG is negative, kill backward."
813 (interactive "*p")
814 (visual-kill-region
815 (point)
816 (progn
817 (visual-forward-word arg)
818 (point))))
819
820 (defun visual-backward-kill-word (arg)
821 "Kill ARG (integer) words visually backward.
822 If ARG is negative, kill forward."
823 (interactive "*p")
824 (visual-kill-region
825 (point)
826 (progn
827 (visual-backward-word arg)
828 (point))))
829
830 (defun visual-kill-line (&optional arg)
831 "kill-line command for visual-mode."
832 (interactive "*P")
833 (visual-kill-region
834 (point)
835 (progn
836 (if arg
837 (progn
838 (forward-line (prefix-numeric-value arg))
839 (visual-beginning-of-line))
840 (if (eobp)
841 (signal 'end-of-buffer nil))
842 (if (not (eolp))
843 (visual-end-of-line)
844 (forward-line 1)
845 (visual-beginning-of-line)))
846 (point))))
847
848 (defun visual-copy-region-as-kill (beg end)
849 "copy-region-as-kill command for visual-mode."
850 (interactive "r")
851 (let ((buffer-read-only nil)
852 (auto-save-mode 0)
853 (p (point)))
854 (visual-kill-region beg end)
855 (visual-yank 1)
856 (if (/= (point) p)
857 (exchange-point-and-mark)))
858 nil)
859
860 (defun visual-kill-ring-save (beg end)
861 "kill-ring-save command for visual-mode."
862 (interactive "r")
863 (visual-copy-region-as-kill beg end)
864 (if (interactive-p)
865 (let ((other-end (if (= (point) beg) end beg))
866 (opoint (point))
867 (inhibit-quit t))
868 (if (pos-visible-in-window-p other-end (selected-window))
869 (progn
870 (set-marker (mark-marker) (point) (current-buffer))
871 (goto-char other-end)
872 (sit-for 1)
873 (set-marker (mark-marker) other-end (current-buffer))
874 (goto-char opoint)
875 (and quit-flag mark-active
876 (deactivate-mark)))
877 (let* ((killed-text (current-kill 0))
878 (message-len (min (length killed-text) 40)))
879 (if (= (point) beg)
880 (message "Saved text until \"%s\""
881 (substring killed-text (- message-len)))
882 (message "Saved text from \"%s\""
883 (substring killed-text 0 message-len))))))))
884
885
886 ;; yank
887
888 (defun visual-yank (&optional arg)
889 "yank command for visual-mode."
890 (interactive "*P")
891 (setq this-command t)
892
893 (let ((l1 (current-line)) (c1 (visual-current-column)) l2 c2)
894
895 ;; Insert a newline both before and after current point.
896 (visual-insert-char ?\n 2)
897 (visual-backward-1-char)
898
899 ;; Reinsert killed string between the two newlines.
900 (insert (current-kill (cond
901 ((listp arg) 0)
902 ((eq arg '-) -1)
903 (t (1- arg)))))
904
905 ;; Delete the latter newline visually.
906 (visual-delete-1-char)
907 (setq l2 (current-line)
908 c2 (visual-current-column))
909
910 ;; Delete the former newline visually.
911 (goto-line l1)
912 (end-of-line)
913 (visual-delete-1-char)
914 (push-mark (point))
915
916 ;; Go back to the end of yanked string.
917 (if (= (- l2 l1) 1)
918 (visual-goto-column (+ c1 c2))
919 (goto-line (1- l2))
920 (visual-goto-column c2))
921
922 ;; Exchange point and mark if necessary.
923 (if (consp arg)
924 (goto-char (prog1 (mark t)
925 (set-marker (mark-marker) (point) (current-buffer))))))
926
927 (setq this-command 'yank)
928 nil)
929
930 (defun visual-yank-pop (arg)
931 "yank-pop command for visual-mode."
932 (interactive "*p")
933 (if (not (eq last-command 'yank))
934 (error "Previous command was not a yank"))
935 (setq this-command 'yank)
936 (let (l1 c1 l2 c2 before)
937
938 (save-excursion
939 (setq l2 (current-line)
940 c2 (visual-current-column))
941 (goto-char (mark t))
942 (setq l1 (current-line)
943 c1 (visual-current-column))
944 (if (or (> l1 l2)
945 (and (= l1 l2) (> c1 c2)))
946 (setq before t)))
947
948 (visual-delete-region (point) (mark t))
949 (setq l1 (current-line)
950 c1 (visual-current-column))
951
952 ;; Insert a newline both before and after current point.
953 (visual-insert-char ?\n 2)
954 (visual-backward-1-char)
955
956 ;; Reinsert killed string between the two newlines.
957 (insert (current-kill arg))
958
959 ;; Delete the latter newline visually.
960 (visual-delete-1-char)
961 (setq l2 (current-line)
962 c2 (visual-current-column))
963
964 ;; Delete the former newline visually.
965 (goto-line l1)
966 (end-of-line)
967 (visual-delete-1-char)
968 (set-marker (mark-marker) (point) (current-buffer))
969
970 ;; Go back to the end of yanked string.
971 (if (= (- l2 l1) 1)
972 (visual-goto-column (+ c1 c2))
973 (goto-line (1- l2))
974 (visual-goto-column c2))
975
976 ;; Exchange point and mark if necessary.
977 (if before
978 (goto-char (prog1 (mark t)
979 (set-marker (mark-marker) (point) (current-buffer))))))
980
981 nil)
982
983
984 ;; misc
985
986 (defun visual-reverse-direction-word nil
987 "Reverse the char order of the word before point."
988 (interactive "*")
989 (goto-char
990 (prog1
991 (point)
992 (reverse-region
993 (point)
994 (progn (skip-direction-backward (visual-char-direction-before-point))
995 (point))))))
996
997 (defun visual-reverse-region (begin end)
998 "Reverse the order of chars between BEGIN and END."
999 (interactive "*r")
1000 (apply 'insert
1001 (nreverse
1002 (string-to-char-list
1003 (prog1 (buffer-substring begin end) (delete-region begin end))))))
1004
1005
1006 ;; LR commands
1007
1008 (defun visual-char-left nil
1009 "Return the character on the left of visual point."
1010 (if display-direction
1011 (visual-char-after)
1012 (visual-char-before)))
1013
1014 (defun visual-char-right nil
1015 "Return the character on the right of visual point."
1016 (if display-direction
1017 (visual-char-before)
1018 (visual-char-after)))
1019
1020 (defun visual-move-to-left-char (arg)
1021 "Move the cursor visually left by ARG (integer) characters.
1022 If ARG is negative, move the cursor right."
1023 (interactive "p")
1024 (if display-direction
1025 (visual-forward-char arg)
1026 (visual-backward-char arg)))
1027
1028 (defun visual-move-to-left-1-char nil
1029 "Move the cursor visually left by 1 character."
1030 (interactive "p")
1031 (if display-direction
1032 (visual-forward-1-char)
1033 (visual-backward-1-char)))
1034
1035 (defun visual-move-to-right-char (arg)
1036 "Move the cursor visually right by ARG (integer) characters.
1037 If ARG is negative, move the cursor left."
1038 (interactive "p")
1039 (if display-direction
1040 (visual-backward-char arg)
1041 (visual-forward-char arg)))
1042
1043 (defun visual-move-to-right-1-char nil
1044 "Move the cursor visually right by 1 character."
1045 (interactive "p")
1046 (if display-direction
1047 (visual-backward-1-char)
1048 (visual-forward-1-char)))
1049
1050 (defun visual-move-to-left-word (arg)
1051 "Move the cursor visually left by ARG (integer) words.
1052 If ARG is negative, move the cursor right."
1053 (interactive "p")
1054 (if display-direction
1055 (visual-forward-word arg)
1056 (visual-backward-word arg)))
1057
1058 (defun visual-move-to-right-word (arg)
1059 "Move the cursor visually right by ARG (integer) words.
1060 If ARG is negative, move the cursor left."
1061 (interactive "p")
1062 (if display-direction
1063 (visual-backward-word arg)
1064 (visual-forward-word arg)))
1065
1066 (defun visual-left-end-of-line (arg)
1067 "Move the line cursor to the left-end of line.
1068 With ARG not nil, move forward ARG - 1 lines first.
1069 If scan reaches end of buffer, stop there without error."
1070 (interactive "P")
1071 (if display-direction
1072 (visual-end-of-line arg)
1073 (visual-beginning-of-line arg)))
1074
1075 (defun visual-right-end-of-line (arg)
1076 "Move the line cursor to the right-end of line.
1077 With ARG not nil, move forward ARG - 1 lines first.
1078 If scan reaches end of buffer, stop there without error."
1079 (interactive "P")
1080 (if display-direction
1081 (visual-beginning-of-line arg)
1082 (visual-end-of-line arg)))
1083
1084 (defun visual-insert-char-left (ch arg)
1085 "Insert CH (character) on the left of visual point as many as
1086 ARG (integer)."
1087 (if (< arg 0)
1088 (error "ARG must be >= 0."))
1089 (visual-insert-char ch arg)
1090 (and display-direction
1091 (visual-backward-char arg)))
1092
1093 (defun visual-insert-left-1-char (ch)
1094 "Insert CH (character) on the left of visual point."
1095 (visual-insert-1-char ch)
1096 (and display-direction
1097 (visual-backward-1-char)))
1098
1099 (defun visual-insert-char-right (ch arg)
1100 "Insert CH (character) on the right of visual point as many as
1101 ARG (integer)."
1102 (if (< arg 0)
1103 (error "ARG must be >= 0."))
1104 (visual-insert-char ch arg)
1105 (or display-direction
1106 (visual-backward-char arg)))
1107
1108 (defun visual-insert-right-1-char (ch)
1109 "Insert CH (character) on the right of visual point."
1110 (visual-insert-1-char ch)
1111 (or display-direction
1112 (visual-backward-1-char)))
1113
1114 (defun visual-delete-left-char (arg)
1115 "Delete ARG (integer) characters on the left of visual point.
1116 If ARG is negative, on the right."
1117 (interactive "*p")
1118 (if display-direction
1119 (visual-delete-char arg)
1120 (visual-backward-delete-char arg)))
1121
1122 (defun visual-delete-left-1-char nil
1123 "Delete 1 character on the left of visual point."
1124 (interactive "*p")
1125 (if display-direction
1126 (visual-delete-1-char)
1127 (visual-backward-delete-1-char)))
1128
1129 (defun visual-delete-right-char (arg)
1130 "Delete ARG (integer) characters on the right of visual point.
1131 If ARG is negative, on the left."
1132 (interactive "*p")
1133 (if display-direction
1134 (visual-backward-delete-char arg)
1135 (visual-delete-char arg)))
1136
1137 (defun visual-delete-right-1-char nil
1138 "Delete 1 character on the right of visual point."
1139 (interactive "*p")
1140 (if display-direction
1141 (visual-backward-delete-1-char)
1142 (visual-delete-1-char)))
1143
1144 (defmacro visual-replace-left-1-char (ch)
1145 (list
1146 'progn
1147 '(visual-delete-left-1-char)
1148 (list 'visual-insert-left-1-char ch)))
1149
1150 (defmacro visual-replace-right-1-char (ch)
1151 (list
1152 'progn
1153 '(visual-delete-right-1-char)
1154 (list 'visual-insert-right-1-char ch)))
1155
1156 (defun visual-kill-left-word (arg)
1157 "Kill ARG (integer) words on the left of visual pointer.
1158 If ARG is negative, kill on the right."
1159 (interactive "*p")
1160 (if display-direction
1161 (visual-kill-word arg)
1162 (visual-backward-kill-word arg)))
1163
1164 (defun visual-kill-right-word (arg)
1165 "Kill ARG (integer) words on the right of visual point.
1166 If ARG is negative, kill on the left."
1167 (interactive "*p")
1168 (if display-direction
1169 (visual-backward-kill-word arg)
1170 (visual-kill-word arg)))
1171
1172 ;;;
1173 (provide 'visual-mode)