[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