home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / modes / multi-forms-mode / my-picture.el < prev    next >
Encoding:
Text File  |  1992-01-06  |  11.3 KB  |  326 lines
  1. ;; "Picture mode" -- editing using quarter-plane screen model.
  2. ;; Copyright (C) 1985 Free Software Foundation, Inc.
  3. ;; Principal author K. Shane Hartman
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22. ;;; This can get hacked up, we can't keep all of picture mode around, even if we
  23. ;;;  would use it, it would clash as a mode.
  24.  
  25. (provide 'my-picture)
  26.  
  27. (defun move-to-column-force (column)
  28.   "Move to column COLUMN in current line.
  29. Differs from move-to-column in that it creates or modifies whitespace
  30. if necessary to attain exactly the specified column."
  31.   (move-to-column column)
  32.   (let ((col (current-column)))
  33.     (if (< col column)
  34.     (indent-to column)
  35.       (if (and (/= col column)
  36.            (= (preceding-char) ?\t))
  37.       (let (indent-tabs-mode)
  38.         (delete-char -1)
  39.             (indent-to col)
  40.             (move-to-column column))))))
  41.  
  42.  
  43. ;; Picture Movement Commands
  44.  
  45. (defun picture-end-of-line (&optional arg)
  46.   "Position point after last non-blank character on current line.
  47. With ARG not nil, move forward ARG - 1 lines first.
  48. If scan reaches end of buffer, stop there without error."
  49.   (interactive "P")
  50.   (if arg (forward-line (1- (prefix-numeric-value arg))))
  51.   (beginning-of-line)
  52.   (skip-chars-backward " \t" (prog1 (point) (end-of-line))))
  53.  
  54. (defun picture-forward-column (arg)
  55.   "Move cursor right, making whitespace if necessary.
  56. With argument, move that many columns."
  57.   (interactive "p")
  58.   (move-to-column-force (+ (current-column) arg)))
  59.  
  60. (defun picture-backward-column (arg)
  61.   "Move cursor left, making whitespace if necessary.
  62. With argument, move that many columns."
  63.   (interactive "p")
  64.   (move-to-column-force (- (current-column) arg)))
  65.  
  66. (defun picture-move-down (arg)
  67.   "Move vertically down, making whitespace if necessary.
  68. With argument, move that many lines."
  69.   (interactive "p")
  70.   (let ((col (current-column)))
  71.     (picture-newline arg)
  72.     (move-to-column-force col)))
  73.  
  74. (defconst picture-vertical-step 0
  75.   "Amount to move vertically after text character in Picture mode.")
  76.  
  77. (defconst picture-horizontal-step 1
  78.   "Amount to move horizontally after text character in Picture mode.")
  79.  
  80. (defun picture-move-up (arg)
  81.   "Move vertically up, making whitespace if necessary.
  82. With argument, move that many lines."
  83.   (interactive "p")
  84.   (picture-move-down (- arg)))
  85.  
  86. (defun picture-movement-right ()
  87.   "Move right after self-inserting character in Picture mode."
  88.   (interactive)
  89.   (picture-set-motion 0 1))
  90.  
  91. (defun picture-movement-left ()
  92.   "Move left after self-inserting character in Picture mode."
  93.   (interactive)
  94.   (picture-set-motion 0 -1))
  95.  
  96. (defun picture-movement-up ()
  97.   "Move up after self-inserting character in Picture mode."
  98.   (interactive)
  99.   (picture-set-motion -1 0))
  100.  
  101. (defun picture-movement-down ()
  102.   "Move down after self-inserting character in Picture mode."
  103.   (interactive)
  104.   (picture-set-motion 1 0))
  105.  
  106. (defun picture-movement-nw ()
  107.   "Move up and left after self-inserting character in Picture mode."
  108.   (interactive)
  109.   (picture-set-motion -1 -1))
  110.  
  111. (defun picture-movement-ne ()
  112.   "Move up and right after self-inserting character in Picture mode."
  113.   (interactive)
  114.   (picture-set-motion -1 1))
  115.  
  116. (defun picture-movement-sw ()
  117.   "Move down and left after self-inserting character in Picture mode."
  118.   (interactive)
  119.   (picture-set-motion 1 -1))
  120.  
  121. (defun picture-movement-se ()
  122.   "Move down and right after self-inserting character in Picture mode."
  123.   (interactive)
  124.   (picture-set-motion 1 1))
  125.  
  126. (defun picture-set-motion (vert horiz)
  127.   "Set VERTICAL and HORIZONTAL increments for movement in Picture mode.
  128. The mode line is updated to reflect the current direction."
  129.   (setq picture-vertical-step vert
  130.     picture-horizontal-step horiz)
  131.   (setq mode-name
  132.     (format "Picture:%s"
  133.         (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2))))
  134.                  '(nw up ne left none right sw down se)))))
  135.   ;; Kludge - force the mode line to be updated.  Is there a better
  136.   ;; way to this?
  137.   (set-buffer-modified-p (buffer-modified-p))
  138.   (message ""))
  139.  
  140. (defun picture-move ()
  141.   "Move in direction of  picture-vertical-step  and  picture-horizontal-step."
  142.   (picture-move-down picture-vertical-step)
  143.   (picture-forward-column picture-horizontal-step))
  144.  
  145. (defun picture-motion (arg)
  146.   "Move point in direction of current picture motion in Picture mode.
  147. With ARG do it that many times.  Useful for delineating rectangles in
  148. conjunction with diagonal picture motion.
  149. Do \\[command-apropos]  picture-movement  to see commands which control motion."
  150.   (interactive "p")
  151.   (picture-move-down (* arg picture-vertical-step))
  152.   (picture-forward-column (* arg picture-horizontal-step)))
  153.  
  154. (defun picture-motion-reverse (arg)
  155.   "Move point in direction opposite of current picture motion in Picture mode.
  156. With ARG do it that many times.  Useful for delineating rectangles in
  157. conjunction with diagonal picture motion.
  158. Do \\[command-apropos]  picture-movement  to see commands which control motion."
  159.   (interactive "p")
  160.   (picture-motion (- arg)))
  161.  
  162.  
  163. ;; Picture insertion and deletion.
  164.  
  165. (defun picture-self-insert (arg)
  166.   "Insert this character in place of character previously at the cursor.
  167. The cursor then moves in the direction you previously specified
  168. with the commands picture-movement-right, picture-movement-up, etc.
  169. Do \\[command-apropos]  picture-movement  to see those commands."
  170.   (interactive "p")
  171.   (while (> arg 0)
  172.     (setq arg (1- arg))
  173.     (move-to-column-force (1+ (current-column)))
  174.     (delete-char -1)
  175.     (insert last-input-char)
  176.     (forward-char -1)
  177.     (picture-move)))
  178.  
  179. (defun picture-clear-column (arg)
  180.   "Clear out ARG columns after point without moving."
  181.   (interactive "p")
  182.   (let* ((opoint (point))
  183.      (original-col (current-column))
  184.      (target-col (+ original-col arg)))
  185.     (move-to-column-force target-col)
  186.     (delete-region opoint (point))
  187.     (save-excursion
  188.      (indent-to (max target-col original-col)))))
  189.  
  190. (defun picture-backward-clear-column (arg)
  191.   "Clear out ARG columns before point, moving back over them."
  192.   (interactive "p")
  193.   (picture-clear-column (- arg)))
  194.  
  195. (defun picture-clear-line (arg)
  196.   "Clear out rest of line; if at end of line, advance to next line.
  197. Cleared-out line text goes into the kill ring, as do
  198. newlines that are advanced over.
  199. With argument, clear out (and save in kill ring) that many lines."
  200.   (interactive "P")
  201.   (if arg
  202.       (progn
  203.        (setq arg (prefix-numeric-value arg))
  204.        (kill-line arg)
  205.        (newline (if (> arg 0) arg (- arg))))
  206.     (if (looking-at "[ \t]*$")
  207.     (kill-ring-save (point) (progn (forward-line 1) (point)))
  208.       (kill-region (point) (progn (end-of-line) (point))))))
  209.  
  210. (defun picture-newline (arg)
  211.   "Move to the beginning of the following line.
  212. With argument, moves that many lines (up, if negative argument);
  213. always moves to the beginning of a line."
  214.   (interactive "p")
  215.   (if (< arg 0)
  216.       (forward-line arg)
  217.     (while (> arg 0)
  218.       (end-of-line)
  219.       (if (eobp) (newline) (forward-char 1))
  220.       (setq arg (1- arg)))))
  221.  
  222. (defun picture-open-line (arg)
  223.   "Insert an empty line after the current line.
  224. With positive argument insert that many lines."
  225.   (interactive "p")
  226.   (save-excursion
  227.    (end-of-line)
  228.    (open-line arg)))
  229.  
  230. (defun picture-duplicate-line ()
  231.   "Insert a duplicate of the current line, below it."
  232.   (interactive)
  233.   (save-excursion
  234.    (let ((contents
  235.       (buffer-substring
  236.        (progn (beginning-of-line) (point))
  237.        (progn (picture-newline 1) (point)))))
  238.      (forward-line -1)
  239.      (insert contents))))
  240.  
  241.  
  242. ;; Picture Tabs
  243. ;;; deleted -fer
  244.  
  245.  
  246. ;; Picture Rectangles
  247.  
  248. (defconst picture-killed-rectangle nil
  249.   "Rectangle killed or copied by \\[picture-clear-rectangle] in Picture mode.
  250. The contents can be retrieved by \\[picture-yank-rectangle]")
  251.  
  252. (defun picture-clear-rectangle (start end &optional killp)
  253.   "Clear and save rectangle delineated by point and mark.
  254. The rectangle is saved for yanking by \\[picture-yank-rectangle] and replaced
  255. with whitespace.  The previously saved rectangle, if any, is lost.
  256. With prefix argument, the rectangle is actually killed, shifting remaining
  257. text."
  258.   (interactive "r\nP")
  259.   (setq picture-killed-rectangle (picture-snarf-rectangle start end killp)))
  260.  
  261. (defun picture-clear-rectangle-to-register (start end register &optional killp)
  262.   "Clear rectangle delineated by point and mark into REGISTER.
  263. The rectangle is saved in REGISTER and replaced with whitespace.
  264. With prefix argument, the rectangle is actually killed, shifting remaining
  265. text."
  266.   (interactive "r\ncRectangle to register: \nP")
  267.   (set-register register (picture-snarf-rectangle start end killp)))
  268.  
  269. (defun picture-snarf-rectangle (start end &optional killp)
  270.   (let ((column (current-column))
  271.     (indent-tabs-mode nil))
  272.     (prog1 (save-excursion
  273.              (if killp
  274.                  (delete-extract-rectangle start end)
  275.                (prog1 (extract-rectangle start end)
  276.                       (clear-rectangle start end))))
  277.        (move-to-column-force column))))
  278.  
  279. (defun picture-yank-rectangle (&optional insertp)
  280.   "Overlay rectangle saved by \\[picture-clear-rectangle]
  281. The rectangle is positioned with upper left corner at point, overwriting
  282. existing text.  With prefix argument, the rectangle is inserted instead,
  283. shifting existing text.  Leaves mark at one corner of rectangle and
  284. point at the other (diagonally opposed) corner."
  285.   (interactive "P")
  286.   (if (not (consp picture-killed-rectangle))
  287.       (error "No rectangle saved.")
  288.     (picture-insert-rectangle picture-killed-rectangle insertp)))
  289.  
  290. (defun picture-yank-rectangle-from-register (register &optional insertp)
  291.   "Overlay rectangle saved in REGISTER.
  292. The rectangle is positioned with upper left corner at point, overwriting
  293. existing text.  With prefix argument, the rectangle is
  294. inserted instead, shifting existing text.  Leaves mark at one corner
  295. of rectangle and point at the other (diagonally opposed) corner."
  296.   (interactive "cRectangle from register: \nP")
  297.   (let ((rectangle (get-register register)))
  298.     (if (not (consp rectangle))
  299.     (error "Register %c does not contain a rectangle." register)
  300.       (picture-insert-rectangle rectangle insertp))))
  301.  
  302. (defun picture-insert-rectangle (rectangle &optional insertp)
  303.   "Overlay RECTANGLE with upper left corner at point.
  304. Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted.
  305. Leaves the region surrounding the rectangle."
  306.   (let ((indent-tabs-mode nil))
  307.     (if (not insertp)
  308.     (save-excursion
  309.       (delete-rectangle (point)
  310.                 (progn
  311.                   (picture-forward-column (length (car rectangle)))
  312.                   (picture-move-down (1- (length rectangle)))
  313.                   (point)))))
  314.     (push-mark)
  315.     (insert-rectangle rectangle)))
  316.  
  317.  
  318. ;; Picture Keymap, entry and exit points.
  319.  
  320. (defun picture-clean ()
  321.   "Eliminate whitespace at ends of lines."
  322.   (save-excursion
  323.    (goto-char (point-min))
  324.    (while (re-search-forward "[ \t][ \t]*$" nil t)
  325.      (delete-region (match-beginning 0) (point)))))
  326.