home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / lisp / edit.jl < prev    next >
Lisp/Scheme  |  1994-04-16  |  8KB  |  241 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 "^ *$"
  25.   "Regular expression which matches a paragraph-separating piece of text.")
  26.  
  27. (set-buffer-variable 'word-regexp)
  28. (set-buffer-variable 'word-not-regexp)
  29. (set-buffer-variable 'paragraph-regexp)
  30.  
  31. (defvar auto-mark (make-mark)
  32.   "Mark which some commands use to track the previous cursor position.")
  33.  
  34. (defun forward-word (&optional number pos)
  35.   "(forward-word [NUMBER] [POS])
  36. Move to the first character after the end of this word.
  37. NUMBER is the number of words to move, negative values mean go backwards."
  38.   (unless number
  39.     (setq number 1))
  40.   (unless pos
  41.     (setq pos (cursor-pos)))
  42.   (cond
  43.     ((< number 0)
  44.       ;; go backwards
  45.       (while (/= number 0)
  46.     (setq pos (prev-char pos))
  47.     (when (looking-at word-not-regexp pos)
  48.       ;; not in word
  49.       (unless (setq pos (find-prev-regexp word-regexp pos))
  50.         (error "Start of buffer")))
  51.     ;; in middle of word
  52.     (unless (setq pos (find-prev-regexp word-not-regexp pos))
  53.       (error "Start of buffer"))
  54.     (setq
  55.       pos (find-next-regexp word-regexp pos)
  56.       number (1+ number)))
  57.       pos)
  58.     (t
  59.       ;; forwards
  60.       (while (/= number 0)
  61.     (when (looking-at word-not-regexp pos)
  62.       ;; already at end of a word
  63.       (unless (setq pos (find-next-regexp word-regexp pos))
  64.         (error "End of buffer")))
  65.     (unless (setq pos (find-next-regexp word-not-regexp pos))
  66.       (error "End of buffer"))
  67.     (setq number (1- number)))
  68.       pos)))
  69.  
  70. (defun backward-word (&optional number pos)
  71.   "(backward-word [NUMBER] [POS])
  72. Basically `(forward-word -NUMBER POS)'"
  73.   (forward-word (if number (- number) -1) pos))
  74.  
  75. (defun word-start (&optional pos)
  76.   (when (looking-at word-regexp pos)
  77.     (unless (find-prev-regexp word-not-regexp pos)
  78.       (error "Start of buffer"))
  79.     (find-next-regexp word-regexp find-last-end-pos)))
  80.  
  81. (defun in-word-p (&optional pos)
  82.   "(in-word-p [POS])
  83. Returns t if POS is inside a word."
  84.   (when (looking-at word-regexp pos)
  85.     t))
  86.  
  87. (defun mark-word (&optional pos)
  88.   "(mark-word [POS])
  89. Marks the word at POS."
  90.   (block-kill)
  91.   (block-start (if pos pos (cursor-pos)))
  92.   (block-end (forward-word pos)))
  93.  
  94. (defun next-paragraph (&optional pos buf)
  95.   "(next-paragraph [POS] [BUFFER])
  96. Returns the position of the start of the next paragraph."
  97.   (unless (find-next-regexp paragraph-regexp (next-char (if pos (dup-pos pos) (cursor-pos))) buf)
  98.     (file-end)))
  99.  
  100. (defun prev-paragraph (&optional pos buf)
  101.   "(prev-paragraph [POS] [BUFFER])
  102. Returns the start of the previous paragraph."
  103.   (unless (find-prev-regexp paragraph-regexp (prev-char (if pos (dup-pos pos) (cursor-pos))) buf)
  104.     (file-start)))
  105.  
  106. (defun mark-paragraph ()
  107.   "(mark-paragraph)
  108. Set the block-marks to the current paragraph."
  109.   (block-kill)
  110.   (let
  111.       ((par (next-paragraph)))
  112.     (block-end par)
  113.     (block-start (prev-paragraph par))))
  114.  
  115. (defun copy-block (&aux rc)
  116.   "(copy-block)
  117. If a block is marked in the current window, return the text it contains and
  118. unmark the block."
  119.   (when (blockp)
  120.     (setq rc (funcall (if (rect-blocks-p) 'copy-rect 'copy-area) (block-start) (block-end)))
  121.     (block-kill))
  122.   rc)
  123.  
  124. (defun cut-block (&aux rc)
  125.   "(cut-block)
  126. Similar to `copy-block' except the block is cut from the buffer."
  127.   (when (blockp)
  128.     (setq rc (funcall (if (rect-blocks-p) 'cut-rect 'cut-area) (block-start) (block-end)))
  129.     (block-kill))
  130.   rc)
  131.  
  132. (defun delete-block ()
  133.   "(delete-block)
  134. Deletes the block marked in the current window (if one exists)."
  135.   (when (blockp)
  136.     (funcall (if (rect-blocks-p) 'delete-rect 'delete-area) (block-start) (block-end))
  137.     (block-kill)))
  138.  
  139. (defun insert-block (&optional pos)
  140.   "(insert-block [POS])
  141. If a block is marked in the current window, copy it to position POS, then
  142. unmark the block."
  143.   (when (blockp)
  144.     (if (rect-blocks-p)
  145.     (insert-rect (copy-rect (block-start) (block-end)) pos)
  146.       (insert (copy-area (block-start) (block-end)) pos))
  147.     (block-kill)))
  148.  
  149. (defun toggle-rect-blocks ()
  150.   (set-rect-blocks nil (not (rect-blocks-p))))
  151.  
  152. (defvar search-regexp nil)
  153. (defvar replace-regexp nil)
  154.  
  155. (defun search-forward (&optional unask)
  156.   (unless unask
  157.     (setq search-regexp (prompt "Find forwards: " search-regexp)))
  158.   (when search-regexp
  159.     (set-auto-mark)
  160.     (goto (find-next-regexp search-regexp (next-char)))))
  161.  
  162. (defun search-backward (&optional unask)
  163.   (unless unask
  164.     (setq search-regexp (prompt "Find backwards: " search-regexp)))
  165.   (when search-regexp
  166.     (set-auto-mark)
  167.     (goto (find-prev-regexp search-regexp (prev-char)))))
  168.  
  169. (defun simple-replace (&optional unask)
  170.   (if (not unask)
  171.     (setq replace-regexp (prompt "Replace with: " replace-regexp)))
  172.   (when (and replace-regexp (replace-regexp search-regexp replace-regexp))
  173.     (set-auto-mark)
  174.     (goto (find-next-regexp search-regexp))))
  175.  
  176. (defun upcase-area (start end &optional buf)
  177.   "(upcase-area START-POS END-POS [BUFFER])
  178. Makes all alpha characters in the specified region of text upper case."
  179.   (translate-area start end upcase-table buf))
  180.  
  181. (defun downcase-area (start end &optional buf)
  182.   "(downcase-area START-POS END-POS [BUFFER])
  183. Makes all alpha characters in the specified region of text lower case."
  184.   (translate-area start end downcase-table buf))
  185.  
  186. (defun upcase-block ()
  187.   "(upcase-block)
  188. Makes all characters in the currently marked block upper case."
  189.   (when (blockp)
  190.     (upcase-area (block-start) (block-end))
  191.     (block-kill)))
  192.  
  193. (defun downcase-block ()
  194.   "(downcase-block)
  195. Makes all characters in the currently marked block lower case."
  196.   (when (blockp)
  197.     (downcase-area (block-start) (block-end))
  198.     (block-kill)))
  199.  
  200. (defun upcase-word ()
  201.   "(upcase-word)
  202. Makes the word under the cursor upper case."
  203.   (let
  204.       ((pos (forward-word)))
  205.     (upcase-area (cursor-pos) pos)
  206.     (goto pos)))
  207.  
  208. (defun downcase-word ()
  209.   "(downcase-word)
  210. Makes the word under the cursor lower case."
  211.   (let
  212.       ((pos (forward-word)))
  213.     (downcase-area (cursor-pos) pos)
  214.     (goto pos)))
  215.  
  216. (defun mark-region ()
  217.   "(mark-region)
  218. Sets the block-marks to the are between the cursor position and the auto-mark"
  219.   (block-kill)
  220.   (when (eq (mark-file auto-mark) (current-buffer))
  221.     (block-kill)
  222.     (let
  223.     ((curs (cursor-pos)))
  224.       (cond
  225.     ((> curs (mark-pos auto-mark))
  226.       (block-start (mark-pos auto-mark))
  227.       (block-end curs))
  228.     (t
  229.       (block-start curs)
  230.       (block-end (mark-pos auto-mark)))))))
  231.  
  232. (defun abort-recursive-edit (&optional ret-val)
  233.   "(abort-recursive-edit [VALUE])
  234. Exits the innermost recursive edit with a value of VALUE."
  235.   (throw 'exit ret-val))
  236.  
  237. (defun top-level ()
  238.   "(top-level)
  239. Exit all recursive-edits."
  240.   (throw 'top-level nil))
  241.