home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / lisp / edit.jl < prev    next >
Lisp/Scheme  |  1994-10-05  |  15KB  |  514 lines
  1. ;;;; edit.jl -- High-level editing functions
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade 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. ;;; Jade 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
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar word-regexp "[a-zA-Z0-9]"
  21.   "Regular expression which defines a character in a word.")
  22. (defvar word-not-regexp "[^a-zA-Z0-9]|$"
  23.   "Regular expression which defines anything that is not in a word.")
  24. (defvar paragraph-regexp "^[\t ]*$"
  25.   "Regular expression which matches a paragraph-separating piece of text.")
  26.  
  27. (make-variable-buffer-local 'word-regexp)
  28. (make-variable-buffer-local 'word-not-regexp)
  29. (make-variable-buffer-local 'paragraph-regexp)
  30.  
  31.  
  32. (defvar auto-mark (make-mark)
  33.   "Mark which some commands use to track the previous cursor position.")
  34.  
  35.  
  36. ;; Words
  37.  
  38. (defun forward-word (&optional number pos move)
  39.   "Return the position of first character after the end of this word.
  40. NUMBER is the number of words to move, negative values mean go backwards.
  41. If MOVE is t then the cursor is moved to the result."
  42.   (interactive "p\n\nt")
  43.   (unless number
  44.     (setq number 1))
  45.   (unless pos
  46.     (setq pos (cursor-pos)))
  47.   (cond
  48.     ((< number 0)
  49.       ;; go backwards
  50.       (while (/= number 0)
  51.     (setq pos (prev-char 1 pos))
  52.     (when (looking-at word-not-regexp pos)
  53.       ;; not in word
  54.       (unless (setq pos (find-prev-regexp word-regexp pos))
  55.         (error "Start of buffer")))
  56.     ;; in middle of word
  57.     (unless (setq pos (find-prev-regexp word-not-regexp pos))
  58.       (error "Start of buffer"))
  59.     (setq
  60.       pos (find-next-regexp word-regexp pos)
  61.       number (1+ number))))
  62.     (t
  63.       ;; forwards
  64.       (while (/= number 0)
  65.     (when (looking-at word-not-regexp pos)
  66.       ;; already at end of a word
  67.       (unless (setq pos (find-next-regexp word-regexp pos))
  68.         (error "End of buffer")))
  69.     (unless (setq pos (find-next-regexp word-not-regexp pos))
  70.       (error "End of buffer"))
  71.     (setq number (1- number)))))
  72.   (when move
  73.     (goto-char pos))
  74.   pos)
  75.  
  76. (defun backward-word (&optional number pos move)
  77.   "Basically `(forward-word -NUMBER POS MOVE)'"
  78.   (interactive "p\n\nt")
  79.   (forward-word (if number (- number) -1) pos move))
  80.  
  81. (defun kill-word (count)
  82.   "Kills from the cursor to the end of the word."
  83.   (interactive "p")
  84.   (kill-area (cursor-pos) (forward-word count)))
  85.  
  86. (defun backward-kill-word (count)
  87.   "Kills from the start of the word to the cursor."
  88.   (interactive "p")
  89.   (kill-area (forward-word (- count)) (cursor-pos)))
  90.  
  91. (defun word-start (&optional pos)
  92.   "Returns the position of the start of *this* word."
  93.   (when (looking-at word-regexp pos)
  94.     (unless (find-prev-regexp word-not-regexp pos)
  95.       (error "Start of buffer"))
  96.     (find-next-regexp word-regexp (match-end))))
  97.  
  98. (defun in-word-p (&optional pos)
  99.   "Returns t if POS is inside a word."
  100.   (when (looking-at word-regexp pos)
  101.     t))
  102.  
  103. (defun mark-word (count &optional pos)
  104.   "Marks COUNT words from POS."
  105.   (interactive "p")
  106.   (set-rect-blocks nil nil)
  107.   (mark-block (or pos (cursor-pos)) (forward-word count pos)))
  108.  
  109. (defun transpose-words (count)
  110.   "Move the word at (before) the cursor COUNT words forwards."
  111.   (interactive "p")
  112.   (transpose-items 'forward-word 'backward-word count))
  113.  
  114.  
  115. ;; Paragraphs
  116.  
  117. (defun forward-paragraph (&optional pos buf move)
  118.   "Returns the position of the start of the next paragraph. If MOVE
  119. is t then the cursor is set to this position."
  120.   (interactive "\n\nt")
  121.   (setq pos (or (find-next-regexp paragraph-regexp
  122.                   (next-char 1 (if pos
  123.                            (copy-pos pos) 
  124.                          (cursor-pos)))
  125.                   buf)
  126.         (buffer-end)))
  127.   (when move
  128.     (goto-char pos))
  129.   pos)
  130.  
  131. (defun backward-paragraph (&optional pos buf move)
  132.   "Returns the start of the previous paragraph. If MOVE is t the cursor is
  133. set to this position."
  134.   (interactive "\n\nt")
  135.   (setq pos (or (find-prev-regexp paragraph-regexp
  136.                   (prev-char 1 (if pos
  137.                            (copy-pos pos)
  138.                          (cursor-pos)))
  139.                   buf)
  140.         (buffer-start)))
  141.   (when move
  142.     (goto-char pos))
  143.   pos)
  144.  
  145. (defun mark-paragraph ()
  146.   "Set the block-marks to the current paragraph."
  147.   (interactive)
  148.   (let
  149.       ((par (forward-paragraph)))
  150.     (set-rect-blocks nil nil)
  151.     (mark-block (backward-paragraph par) par)))
  152.  
  153.  
  154. ;; Block handling
  155.  
  156. (defun copy-block (&aux rc)
  157.   "If a block is marked in the current window, return the text it contains and
  158. unmark the block."
  159.   (when (blockp)
  160.     (setq rc (funcall (if (rect-blocks-p) 'copy-rect 'copy-area)
  161.               (block-start) (block-end)))
  162.     (block-kill))
  163.   rc)
  164.  
  165. (defun cut-block (&aux rc)
  166.   "Similar to `copy-block' except the block is cut (copied then deleted) from
  167. the buffer."
  168.   (when (blockp)
  169.     (setq rc (funcall (if (rect-blocks-p) 'cut-rect 'cut-area)
  170.               (block-start) (block-end)))
  171.     (block-kill))
  172.   rc)
  173.  
  174. (defun delete-block ()
  175.   "Deletes the block marked in the current window (if one exists)."
  176.   (interactive)
  177.   (when (blockp)
  178.     (funcall (if (rect-blocks-p) 'delete-rect 'delete-area)
  179.          (block-start) (block-end))
  180.     (block-kill)))
  181.  
  182. (defun insert-block (&optional pos)
  183.   "If a block is marked in the current window, copy it to position POS, then
  184. unmark the block."
  185.   (interactive)
  186.   (when (blockp)
  187.     (if (rect-blocks-p)
  188.     (insert-rect (copy-rect (block-start) (block-end)) pos)
  189.       (insert (copy-area (block-start) (block-end)) pos))
  190.     (block-kill)))
  191.  
  192. (defun toggle-rect-blocks ()
  193.   "Toggles the state of the flag saying whether blocks in this window are
  194. marked sequentially (the default) or as rectangles."
  195.   (interactive)
  196.   (set-rect-blocks nil (not (rect-blocks-p))))
  197.  
  198. (defun kill-block ()
  199.   "Kills the block marked in this window."
  200.   (interactive)
  201.   (kill-string (cut-block)))
  202.  
  203. (defun copy-block-as-kill ()
  204.   "Kills the block marked in this window but doesn't actually delete it from
  205. the buffer."
  206.   (interactive)
  207.   (kill-string (copy-block)))
  208.  
  209. (defun mark-block (start end)
  210.   "Mark a block from START to END. This does an extra redraw if there's already
  211. a block marked to save lots of flicker."
  212.   (if (blockp)
  213.       (progn
  214.     (block-kill)
  215.     ;; Cunning hack -- the refresh algorithm(?) doesn't like the block
  216.     ;; killed then reset in one go, the whole screen is redraw :-( So
  217.     ;; do two refreshes...
  218.     (refresh-all))
  219.     (block-kill))
  220.   (block-start start)
  221.   (block-end end))
  222.  
  223. (defun mark-whole-buffer ()
  224.   "Mark a block containing the whole of the buffer."
  225.   (interactive)
  226.   (set-rect-blocks nil nil)
  227.   (mark-block (buffer-start) (buffer-end)))
  228.  
  229.  
  230. (defun upcase-area (start end &optional buffer)
  231.   "Makes all alpha characters in the specified region of text upper-case."
  232.   (interactive "-m\nM")
  233.   (translate-area start end upcase-table buffer))
  234.  
  235. (defun downcase-area (start end &optional buffer)
  236.   "Makes all alpha characters in the specified region of text lower-case."
  237.   (interactive "-m\nM")
  238.   (translate-area start end downcase-table buffer))
  239.  
  240. (defun upcase-word (count)
  241.   "Makes the next COUNT words from the cursor upper-case."
  242.   (interactive "p")
  243.   (let
  244.       ((pos (forward-word count)))
  245.     (upcase-area (cursor-pos) pos)
  246.     (goto-char pos)))
  247.  
  248. (defun capitalize-word ()
  249.   "The first character of this word (the one under the cursor) is made
  250. upper-case, the rest lower-case."
  251.   (interactive)
  252.   (unless (in-word-p)
  253.     (goto-char (find-next-regexp word-regexp)))
  254.   (translate-area (cursor-pos) (next-char) upcase-table)
  255.   (goto-next-char)
  256.   (when (in-word-p)
  257.     (downcase-word 1)))
  258.  
  259. (defun downcase-word (count)
  260.   "Makes the word under the cursor lower case."
  261.   (interactive "p")
  262.   (let
  263.       ((pos (forward-word count)))
  264.     (downcase-area (cursor-pos) pos)
  265.     (goto-char pos)))
  266.  
  267.  
  268. (defun mark-region ()
  269.   "Sets the block-marks to the area between the cursor position and the
  270. au