[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Mon Sep 4 09:00:31 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv26441
Modified Files:
packages.lisp misc-commands.lisp
Added Files:
rectangle.lisp
Log Message:
Added GNU Emacs-style rectangle editing.
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 07:05:21 1.115
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 09:00:30 1.116
@@ -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
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/02 10:17:52 1.23
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/04 09:00:30 1.24
@@ -755,3 +755,108 @@
(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)))
--- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/04 09:00:31 NONE
+++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/04 09:00:31 1.1
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas at 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)
, at 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)))))
More information about the Climacs-cvs
mailing list