Commit ed0276e9 authored by Troels Henriksen's avatar Troels Henriksen
Browse files

Added GNU Emacs-style rectangle editing.

parent 36079d56
......@@ -755,3 +755,108 @@ FIXME: no it doesn't."
(define-command (com-visible-region :name t :command-table marking-table) ()
"Toggle the visibility of the region in the current pane."
(setf (region-visible-p (current-window)) (not (region-visible-p (current-window)))))
(define-command (com-kill-rectangle :name t :command-table deletion-table)
()
"Kill the rectangle bounded by current point and mark.
The rectangle will be put in a rectangle kill buffer, from which it can
later be yanked with Yank Rectangle. This kill buffer is completely
disjunct from the standard kill ring and can only hold a single rectangle at a time."
(setf *killed-rectangle*
(map-rectangle-lines (current-buffer)
#'extract-and-delete-rectangle-line
(current-point)
(current-mark))))
(set-key 'com-kill-rectangle
'deletion-table
'((#\x :control) (#\r) (#\k)))
(define-command (com-delete-rectangle :name t :command-table deletion-table)
()
"Delete the rectangle bounded by current point and mark.
The rectangle will be deleted and NOT put in the kill buffer."
(map-rectangle-lines (current-buffer)
#'extract-and-delete-rectangle-line
(current-point)
(current-mark)))
(set-key 'com-delete-rectangle
'deletion-table
'((#\x :control) (#\r) (#\d)))
(define-command (com-yank-rectangle :name t :command-table editing-table)
()
"Insert the rectangle from the rectangle kill buffer at mark.
The rectangle kill buffer will not be emptied, so it is possible to yank
the same rectangle several times."
(insert-rectangle-at-mark (current-buffer)
(current-point)
*killed-rectangle*))
(set-key 'com-yank-rectangle
'editing-table
'((#\x :control) (#\r) (#\y)))
(define-command (com-clear-rectangle :name t :command-table deletion-table)
()
"Clear the rectangle bounded by current point and mark by filling it with spaces."
(map-rectangle-lines (current-buffer)
#'clear-rectangle-line
(current-point)
(current-mark)))
(set-key 'com-clear-rectangle
'editing-table
'((#\x :control) (#\r) (#\c)))
(define-command (com-open-rectangle :name t :command-table editing-table)
()
"Open the rectangle bounded by current point and mark.
The rectangle will not be deleted, but instead pushed to the right, with
the area previously inhabited by it filled with spaces."
(map-rectangle-lines (current-buffer)
#'open-rectangle-line
(current-point)
(current-mark)))
(set-key 'com-open-rectangle
'editing-table
'((#\x :control) (#\r) (#\o)))
(define-command (com-string-rectangle :name t :command-table editing-table)
((string 'string :prompt "String rectangle"))
"Replace each line of the rectangle bounded by current point of mark with `string'.
The length of the string need not be equal to the width of the rectangle."
(map-rectangle-lines (current-buffer)
#'(lambda (mark startcol endcol)
(replace-rectangle-line mark startcol endcol string))
(current-point)
(current-mark)))
(set-key 'com-string-rectangle
'editing-table
'((#\x :control) (#\r) (#\t)))
(define-command (com-string-insert-rectangle :name t :command-table editing-table)
((string 'string :prompt "String rectangle"))
"Insert `string' in each line of the rectangle bounded by current point of mark.
Text in the rectangle will be shifted right."
(map-rectangle-lines (current-buffer)
#'(lambda (mark startcol endcol)
(insert-in-rectangle-line mark startcol endcol string))
(current-point)
(current-mark)))
(define-command (com-delete-whitespace-rectangle :name t :command-table editing-table)
()
(map-rectangle-lines (current-buffer)
#'delete-rectangle-line-whitespace
(current-point)
(current-mark)))
......@@ -420,7 +420,17 @@
#:input-from-stream
#:save-buffer-to-stream
#:make-buffer-from-stream)
#:make-buffer-from-stream
#:*killed-rectangle*
#:map-rectangle-lines
#:extract-and-delete-rectangle-line
#:insert-rectangle-at-mark
#:clear-rectangle-line
#:open-rectangle-line
#:replace-rectangle-line
#:insert-in-rectangle-line
#:delete-rectangle-line-whitespace)
(:documentation "Package for editor functionality that is
syntax-aware, but yet not specific to certain
syntaxes. Contains stuff like indentation, filling and other
......
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Implementation of rectangle editing.
(in-package :climacs-core)
(defvar *killed-rectangle* nil
"The killed rectangle as a list of lines.")
(defun map-rectangle-lines (buffer function start end)
"Map over lines in rectangle, calling `function' for each line.
The rectangle is defined by the marks `start' and `end'. For each
line, `function' will be called with arguments of a mark situated at
the beginning of the line, the starting column of the rectangle and
the ending column of the rectangle. This function returns a list of
the return values of `function'."
(let ((startcol (column-number start))
(endcol (column-number end))
(mark (clone-mark (point buffer))))
(when (> startcol endcol)
(rotatef startcol endcol))
(when (mark> start end)
(rotatef start end))
(setf (offset mark) (offset start))
(loop do (beginning-of-line mark)
until (mark> mark end)
collect (funcall function (clone-mark mark) startcol endcol)
until (not (forward-line mark (syntax buffer) 1 nil)))))
(defmacro with-bounding-marks (((start-mark end-mark) mark startcol endcol
&key force-start force-end) &body body)
"Evaluate `body' with `start-mark' and `end-mark' bound to marks
delimiting the rectangle area. The rectangle area is defined as the
part of the line that `mark' is situated in, that lies between the
columns `startcol' and `endcol'. If `force-start' or `force-end' is
non-NIL, the line will be padded with space characters in order to put
`start-mark' or `end-mark' at their specified columns respectively."
(let ((mark-val-sym (gensym))
(startcol-val-sym (gensym))
(endcol-val-sym (gensym)))
`(progn
(let ((,mark-val-sym ,mark)
(,startcol-val-sym ,startcol)
(,endcol-val-sym ,endcol))
(move-to-column ,mark-val-sym ,startcol-val-sym ,force-start)
(let ((,start-mark (clone-mark ,mark-val-sym)))
(let ((,end-mark (clone-mark ,mark-val-sym)))
(move-to-column ,end-mark ,endcol-val-sym ,force-end)
,@body))))))
(defun extract-and-delete-rectangle-line (mark startcol endcol)
"For the line that `mark' is in, delete and return the string
between column `startcol' and `endcol'. If the string to be returned
is not as wide as the rectangle, it will be right-padded with space
characters."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol)
(let ((str (concatenate 'string (buffer-substring (buffer mark)
(offset start-mark)
(offset end-mark))
(make-string (- endcol (column-number end-mark)) :initial-element #\Space))))
(delete-range start-mark (- (offset end-mark) (offset start-mark)))
str)))
(defun delete-rectangle-line (mark startcol endcol)
"For the line that `mark' is in, delete the string
between column `startcol' and `endcol'."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol)
(delete-range start-mark (- (offset end-mark) (offset start-mark)))))
(defun open-rectangle-line (mark startcol endcol)
"For the line that `mark' is in, move the string between column
`startcol' and `endcol' to the right, replacing the area previously
inhabited by it with space characters."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol)
(unless (mark= start-mark end-mark)
(insert-sequence start-mark (make-string (- endcol startcol) :initial-element #\Space)))))
(defun clear-rectangle-line (mark startcol endcol)
"For the line that `mark' is in, replace the string between column
`startcol' and `endcol' with space characters."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol)
(let ((size (- (offset end-mark) (offset start-mark))))
(delete-range start-mark size)
(insert-sequence start-mark (make-string size :initial-element #\Space)))))
(defun delete-rectangle-line-whitespace (mark startcol endcol)
"For the line that `mark' is in, delete all whitespace characters
from `startcol' up to the first non-whitespace character."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol)
(let ((target-mark (clone-mark start-mark)))
(re-search-forward target-mark "[^ ]")
(when (= (line-number start-mark) (line-number target-mark))
(delete-range start-mark (- (offset target-mark) (offset start-mark) 1))))))
(defun replace-rectangle-line (mark startcol endcol string)
"For the line that `mark' is in, replace the string between column
`startcol' and `endcol' with `string'."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol :force-start t)
(delete-range start-mark (- (offset end-mark) (offset start-mark)))
(insert-sequence start-mark string)))
(defun insert-in-rectangle-line (mark startcol endcol string)
"For the line that `mark' is in, move the string between column
`startcol' and `endcol' to the right, replacing the area previously
inhabited by it with the contents of `string'."
(with-bounding-marks ((start-mark end-mark) mark startcol endcol :force-start t)
(insert-sequence start-mark string)))
(defun insert-rectangle-at-mark (buffer mark rectangle)
"Yank the killed rectangle, positioning the upper left corner at
current point."
(let ((insert-column (column-number mark)))
(dolist (line rectangle)
(move-to-column mark insert-column t)
(insert-sequence mark line)
(unless (forward-line mark (syntax buffer) 1 nil)
(open-line mark)
(forward-object mark)))))
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment