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@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)))))