Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16638

Modified Files: gui.lisp kill-ring.lisp packages.lisp Log Message: kill ring updated and functioning protocol. Enjoy C-k and M-y like you never have in climacs before:) Date: Fri Jan 7 14:07:46 2005 Author: ejohnson

Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.49 climacs/gui.lisp:1.50 --- climacs/gui.lisp:1.49 Fri Jan 7 08:26:24 2005 +++ climacs/gui.lisp Fri Jan 7 14:07:45 2005 @@ -128,7 +128,7 @@ (setf table (command-menu-item-value item))) finally (return item)))

-(defvar *kill-ring* (initialize-kill-ring 7)) +(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) (defparameter *current-gesture* nil)

(defun meta-digit (gesture) @@ -347,7 +347,22 @@ (open-line (point (win *application-frame*))))

(define-named-command com-kill-line () - (kill-line (point (win *application-frame*)))) + (let* ((payne (win *application-frame*)) + (pnt (point payne))) + (if (and (beginning-of-buffer-p pnt) + (end-of-line-p pnt)) + NIL + (let ((mrk (offset pnt))) + (end-of-line pnt) + (if (end-of-buffer-p pnt) + nil + (forward-object pnt)) + (if (eq (previous-command payne) 'com-kill-line) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mrk pnt)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mrk pnt))) + (delete-region mrk pnt)))))

(define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -552,25 +567,23 @@ ;; Kill ring commands

;; Copies an element from a kill-ring to a buffer at the given offset -(define-named-command com-copy-in () - (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*))) - -;; Cuts an element from a kill-ring out to a buffer at a given offset -(define-named-command com-cut-in () - (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*))) +(define-named-command com-yank () + (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*)))

;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (if (< (offset point) (offset mark)) - ((lambda (b o1 o2) - (kr-push *kill-ring* (buffer-sequence b o1 o2)) - (delete-buffer-range b o1 (- o2 o1))) - buffer (offset point) (offset mark)) - ((lambda (b o1 o2) - (kr-push *kill-ring* (buffer-sequence b o2 o1)) - (delete-buffer-range b o1 (- o2 o1))) - buffer (offset mark) (offset point))))) + (let ((offp (offset point)) + (offm (offset mark))) + (if (< offp offm) + ((lambda (b o1 o2) + (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2)) + (delete-buffer-range b o1 (- o2 o1))) + buffer offp offm) + ((lambda (b o1 o2) + (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1)) + (delete-buffer-range b o1 (- o2 o1))) + buffer offm offp)))))

;; Non destructively copies in buffer region to the kill ring @@ -579,17 +592,25 @@ (let ((off1 (offset point)) (off2 (offset mark))) (if (< off1 off2) - (kr-push *kill-ring* (buffer-sequence buffer off1 off2)) - (kr-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2)) + (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1)))))) +

-;; Needs adjustment to be like emacs M-y -(define-named-command com-kr-rotate () - (kr-rotate *kill-ring* -1)) +(define-named-command com-rotate-yank () + (let* ((payne (win *application-frame*)) + (pnt (point payne)) + (last-yank (kill-ring-yank *kill-ring*))) + (if (eq (previous-command payne) + 'com-rotate-yank) + ((lambda (p ly) + (delete-range p (* -1 (length ly))) + (rotate-yank-position *kill-ring*)) + pnt last-yank)) + (insert-sequence pnt (kill-ring-yank *kill-ring*))))

-;; Not bound to a key yet -(define-named-command com-kr-resize () +(define-named-command com-resize-kill-ring () (let ((size (accept 'integer :prompt "New kill ring size"))) - (kr-resize *kill-ring* size))) + (setf (kill-ring-max-size *kill-ring*) size)))

(define-named-command com-search-forward () (search-forward (point (win *application-frame*)) @@ -666,13 +687,13 @@ (global-set-key '(#\k :control) 'com-kill-line) (global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark) -(global-set-key '(#\y :control) 'com-copy-in) +(global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-cut-out) (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) (global-set-key '(#\t :meta) 'com-transpose-words) (global-set-key '(#\x :meta) 'com-extended-command) -(global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only +(global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up)

Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.3 climacs/kill-ring.lisp:1.4 --- climacs/kill-ring.lisp:1.3 Thu Dec 30 04:55:14 2004 +++ climacs/kill-ring.lisp Fri Jan 7 14:07:45 2005 @@ -25,70 +25,112 @@ (in-package :climacs-kill-ring)

(defclass kill-ring () - ((max-size :type unsigned-byte - :initarg :max-size - :accessor kr-max-size) - (flexichain :type standard-flexichain - :initarg :flexichain - :accessor kr-flexi)) - (:documentation "Basic flexichain without resizing")) - -(defun initialize-kill-ring (size) - "Construct a kill ring of a given size" - (make-instance 'kill-ring - :max-size size - :flexichain (make-instance 'standard-flexichain))) - - -(defgeneric kr-length (kr) - (:documentation "Returns the length of a kill-ring's flexichain")) - -(defmethod kr-length ((kr kill-ring)) - (nb-elements (kr-flexi kr))) - -(defgeneric kr-resize (kr size) - (:documentation "Resize a kill ring to the value of SIZE")) - -(defmethod kr-resize ((kr kill-ring) size) - (setf (slot-value kr 'max-size) size) - (let ((len (kr-length kr))) + ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol + :initarg :max-size) + (cursorchain :type standard-cursorchain + :accessor kill-ring-chain + :initform (make-instance 'standard-cursorchain)) + (yankpoint :type left-sticky-flexicursor + :accessor kill-ring-cursor)) + (:documentation "A class for all kill rings")) + +(defmethod initialize-instance :after((kr kill-ring) &rest args) + "Adds in the yankpoint" + (declare (ignore args)) + (with-slots (cursorchain yankpoint) kr + (setf yankpoint (make-instance 'left-sticky-flexicursor :chain cursorchain)))) + +(defgeneric kill-ring-length (kr) + (:documentation "Returns the current length of the kill ring")) + +(defgeneric kill-ring-max-size (kr) + (:documentation "Returns the value of a kill ring's maximum size")) + +(defgeneric (setf kill-ring-max-size) (kr size) + (:documentation "Alters the maximum size of a kill ring, even +if it means dropping elements to do so.")) + +(defgeneric reset-yank-position (kr) + (:documentation "Moves the current yank point back to the start of + of kill ring position")) + +(defgeneric rotate-yank-position (kr &optional times) + (:documentation "Moves the yank point associated with a kill-ring + one or times many positions away from the start + of ring position. If times is greater than the + current length then the cursor will wrap to the + start of ring position and continue rotating.")) + +(defgeneric kill-ring-standard-push (kr vector) + (:documentation "Pushes a vector of objects onto the kill ring creating a new +start of ring position. This function is much like an every- +day lisp push with size considerations. If the length of the +kill ring is greater than the maximum size, then "older" +elements will be removed from the ring until the maximum size +is reached.")) + +(defgeneric kill-ring-concatenating-push (kr vector) + (:documentation "Concatenates the contents of vector onto the end + of the current contents of the top of the kill ring. + If the kill ring is empty the a new entry is pushed.")) + +(defgeneric kill-ring-yank (kr &optional reset) + (:documentation "Returns the vector of objects currently pointed to + by the cursor. If reset is T, a call to + reset-yank-position is called befor the object is + yanked. The default for reset is NIL")) + +(defmethod kill-ring-length ((kr kill-ring)) + (nb-elements (kill-ring-chain kr))) + +(defmethod kill-ring-max-size ((kr kill-ring)) + (with-slots (max-size) kr + max-size)) + +(defmethod (setf kill-ring-max-size) ((kr kill-ring) size) + (unless (typep size 'integer) + (error "Error, ~S, is not an integer value" size)) + (if (< size 5) + (set (slot-value kr 'max-size) 5) + (setf (slot-value kr 'max-size) size)) + (let ((len (kill-ring-length kr))) (if (> len size) (loop for n from 1 to (- len size) - do (pop-end (kr-flexi kr)))))) + do (pop-end (kill-ring-chain kr))))))

-(defgeneric kr-push (kr object) - (:documentation "Push an object onto a kill ring with size considerations")) - -(defmethod kr-push ((kr kill-ring) object) - (let ((flexi (kr-flexi kr))) - (if (>= (kr-length kr)(kr-max-size kr)) +(defmethod reset-yank-position ((kr kill-ring)) + (setf (cursor-pos (kill-ring-cursor kr)) 0) + t) + +(defmethod rotate-yank-position ((kr kill-ring) &optional (times 1)) + (if (> (kill-ring-length kr) 0) + (let* ((curs (kill-ring-cursor kr)) + (pos (mod (+ times (cursor-pos curs)) + (kill-ring-length kr)))) + (setf (cursor-pos curs) pos)))) + +(defmethod kill-ring-standard-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (>= (kill-ring-length kr) + (kill-ring-max-size kr)) ((lambda (flex obj) (pop-end flex) (push-start flex obj)) - flexi object) - (push-start flexi object)))) - -(defgeneric kr-pop (kr) - (:documentation "Pops an object off of a kill ring")) - -(defmethod kr-pop ((kr kill-ring)) - (if (> (nb-elements (kr-flexi kr)) 0) - (pop-start (kr-flexi kr)) - nil)) - -(defgeneric kr-rotate (kr &optional n) - (:documentation "Rotates the kill ring either once forward or an optional amound +/-")) - -(defmethod kr-rotate ((kr kill-ring) &optional (n -1)) - (assert (typep n 'fixnum)(n) "Can not rotate the kill ring ~S positions" n) - (let ((flexi (kr-flexi kr))) - (rotate flexi n))) - -(defgeneric kr-copy (kr) - (:documentation "Copies out a member of a kill ring without deleting it")) - -(defmethod kr-copy ((kr kill-ring)) - (let ((object (kr-pop kr))) - (kr-push kr object) - object)) + chain vector) + (push-start chain vector))) + (reset-yank-position kr)) + +(defmethod kill-ring-concatenating-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (zerop (kill-ring-length kr)) + (push-start chain vector) + (push-start chain + (concatenate 'vector + (pop-start chain) + vector)))) + (reset-yank-position kr)) + +(defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) + (if reset (reset-yank-position kr)) + (element> (kill-ring-cursor kr)))

Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.21 climacs/packages.lisp:1.22 --- climacs/packages.lisp:1.21 Fri Jan 7 08:26:24 2005 +++ climacs/packages.lisp Fri Jan 7 14:07:45 2005 @@ -52,8 +52,7 @@ #:name-mixin #:name #:buffer-lookin-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward - #:buffer-search-word-backward #:buffer-search-word-forward)) + #:search-forward #:search-backward))

(defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -68,10 +67,10 @@ #:url))

(defpackage :climacs-kill-ring - (:use :clim-lisp :climacs-buffer :flexichain) - (:export #:initialize-kill-ring #:kr-length - #:kr-resize #:kr-rotate #:kill-ring - #:kr-copy #:kr-push #:kr-pop)) + (:use :clim-lisp :flexichain) + (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size + #:reset-yank-position #:rotate-yank-position #:kill-ring-yank + #:kill-ring-standard-push #:kill-ring-concatenating-push))

(defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring))