/[mcclim]/mcclim/Drei/kill-ring.lisp
ViewVC logotype

Contents of /mcclim/Drei/kill-ring.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Mar 28 21:09:43 2008 UTC (6 years ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.4: +1 -1 lines
Drei kill rings are now global.
1 ;;; -*- Mode: Lisp; Package: DREI-KILL-RING -*-
2
3 ;;; (c) copyright 2004 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; kill ring system
24
25 (in-package :drei-kill-ring)
26
27 (defgeneric kill-ring-chain (ring)
28 (:documentation "Return the cursorchain associated with the
29 kill ring `ring'."))
30
31 (defgeneric kill-ring-cursor (ring)
32 (:documentation "Return the flexicursor associated with the
33 kill ring."))
34
35 (defclass kill-ring ()
36 ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol
37 :initarg :max-size
38 :documentation "The limitation placed upon the
39 number of elements held by the kill ring. Once the maximum size
40 has been reached, older entries must first be removed before new
41 ones can be added. When altered, any surplus elements will be
42 silently dropped.")
43 (cursorchain :type standard-cursorchain
44 :accessor kill-ring-chain
45 :initform (make-instance 'standard-cursorchain)
46 :documentation "The cursorchain associated with
47 the kill ring.")
48 (yankpoint :type left-sticky-flexicursor
49 :accessor kill-ring-cursor
50 :documentation "The flexicursor associated with
51 the kill ring.")
52 (append-next-p :type boolean :initform nil
53 :accessor append-next-p))
54 (:documentation "A class for all kill rings"))
55
56 (define-condition empty-kill-ring (simple-error)
57 ()
58 (:report (lambda (condition stream)
59 (declare (ignore condition))
60 (format stream "The kill ring is empty")))
61 (:documentation "This condition is signaled whenever a yank
62 operation is performed on an empty kill ring."))
63
64 (defmethod initialize-instance :after ((kr kill-ring) &rest args)
65 "Adds in the yankpoint"
66 (declare (ignore args))
67 (with-slots (cursorchain yankpoint) kr
68 (setf yankpoint (make-instance 'left-sticky-flexicursor :chain cursorchain))))
69
70 (defgeneric kill-ring-length (kr)
71 (:documentation "Returns the current length of the kill-ring.
72 Note this is different than `kill-ring-max-size'."))
73
74 (defgeneric kill-ring-max-size (kr)
75 (:documentation "Returns the value of the kill ring's maximum
76 size"))
77
78 (defgeneric (setf kill-ring-max-size) (kr size)
79 (:documentation "Alters the maximum size of the kill ring, even
80 if it means dropping elements to do so."))
81
82 (defgeneric reset-yank-position (kr)
83 (:documentation "Moves the current yank point back to the start
84 of of kill ring position"))
85
86 (defgeneric rotate-yank-position (kr &optional times)
87 (:documentation "Moves the yank point associated with a
88 kill-ring one or times many positions away from the start of ring
89 position. If times is greater than the current length then the
90 cursor will wrap to the start of ring position and continue
91 rotating."))
92
93 (defgeneric kill-ring-standard-push (kr vector)
94 (:documentation "Pushes a vector of objects onto the kill ring
95 creating a new start of ring position. This function is much
96 like an everyday Lisp push with size considerations. If the
97 length of the kill ring is greater than the maximum size, then
98 \"older\" elements will be removed from the ring until the
99 maximum size is reached."))
100
101 (defgeneric kill-ring-concatenating-push (kr vector)
102 (:documentation "Concatenates the contents of vector onto the
103 end of the current contents of the top of the kill ring. If the
104 kill ring is empty the a new entry is pushed."))
105
106 (defgeneric kill-ring-reverse-concatenating-push (kr vector)
107 (:documentation "Concatenates the contents of vector onto the front
108 of the current contents of the top of the kill ring. If the kill ring
109 is empty a new entry is pushed."))
110
111 (defgeneric kill-ring-yank (kr &optional reset)
112 (:documentation "Returns the vector of objects currently
113 pointed to by the cursor. If `reset' is T, a call to
114 `reset-yank-position' is called before the object is yanked. The
115 default for reset is NIL. If the kill ring is empty, a condition
116 of type `empty-kill-ring' is signalled."))
117
118 (defmethod kill-ring-length ((kr kill-ring))
119 (nb-elements (kill-ring-chain kr)))
120
121 (defmethod kill-ring-max-size ((kr kill-ring))
122 (with-slots (max-size) kr
123 max-size))
124
125 (defmethod (setf kill-ring-max-size) (size (kr kill-ring))
126 (unless (typep size 'integer)
127 (error "Error, ~S, is not an integer value" size))
128 (if (< size 5)
129 (setf (slot-value kr 'max-size) 5)
130 (setf (slot-value kr 'max-size) size))
131 (let ((len (kill-ring-length kr)))
132 (if (> len size)
133 (loop for n from 1 to (- len size)
134 do (pop-end (kill-ring-chain kr))))))
135
136 (defmethod reset-yank-position ((kr kill-ring))
137 (setf (cursor-pos (kill-ring-cursor kr)) 0)
138 t)
139
140 (defmethod rotate-yank-position ((kr kill-ring) &optional (times 1))
141 (if (> (kill-ring-length kr) 0)
142 (let* ((curs (kill-ring-cursor kr))
143 (pos (mod (+ times (cursor-pos curs))
144 (kill-ring-length kr))))
145 (setf (cursor-pos curs) pos))))
146
147 (defmethod kill-ring-standard-push ((kr kill-ring) vector)
148 (check-type vector vector)
149 (cond ((append-next-p kr)
150 (kill-ring-concatenating-push kr vector)
151 (setf (append-next-p kr) nil))
152 (t (let ((chain (kill-ring-chain kr)))
153 (if (>= (kill-ring-length kr)
154 (kill-ring-max-size kr))
155 (progn
156 (pop-end chain)
157 (push-start chain vector))
158 (push-start chain vector)))
159 (reset-yank-position kr))))
160
161 (defmethod kill-ring-concatenating-push ((kr kill-ring) vector)
162 (check-type vector vector)
163 (let ((chain (kill-ring-chain kr)))
164 (if (zerop (kill-ring-length kr))
165 (push-start chain vector)
166 (push-start chain
167 (concatenate 'vector
168 (pop-start chain)
169 vector)))
170 (reset-yank-position kr)))
171
172 (defmethod kill-ring-reverse-concatenating-push ((kr kill-ring) vector)
173 (check-type vector vector)
174 (let ((chain (kill-ring-chain kr)))
175 (if (zerop (kill-ring-length kr))
176 (push-start chain vector)
177 (push-start chain
178 (concatenate 'vector
179 vector
180 (pop-start chain))))
181 (reset-yank-position kr)))
182
183 (defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil))
184 (assert (plusp (kill-ring-length kr))
185 ()
186 (make-condition 'empty-kill-ring))
187 (if reset (reset-yank-position kr))
188 (element> (kill-ring-cursor kr)))
189
190 (defparameter *kill-ring* (make-instance 'kill-ring :max-size 7)
191 "This special variable is bound to the kill ring of the running
192 application or Drei instance whenever a command is executed.")

  ViewVC Help
Powered by ViewVC 1.1.5