[climacs-cvs] CVS update: climacs/gui.lisp climacs/kill-ring.lisp climacs/packages.lisp
Elliott Johnson
ejohnson at common-lisp.net
Fri Jan 7 13:07:50 UTC 2005
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))
More information about the Climacs-cvs
mailing list