/[mcclim]/mcclim/text-selection.lisp
ViewVC logotype

Contents of /mcclim/text-selection.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Sat Aug 1 16:10:32 2009 UTC (4 years, 8 months ago) by gbaumann
Branch: MAIN
CVS Tags: HEAD
Changes since 1.8: +1 -1 lines
Use force-output instead of finish-output as the latter implies
waiting for an answer from the display server, which is something
we really do not want to do.
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIMI; -*-
2
3 ;;; (c) copyright 2003 by Gilbert Baumann
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20
21
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 ;;;
24 ;;; Cut and Paste
25
26 (in-package :climi)
27
28 ;;;; Interaction implemented:
29
30 ;; Shift-Mouse-L down: clear active selection and set the first point
31 ;; Shift-Mouse-L drag: drag the second point
32 ;; Shift-Mouse-L up: set the second point
33
34 ;; Shift-Mouse-R down: pick the nearest point, if any
35 ;; Shift-Mouse-R drag: drag said point
36 ;; Shift-Mouse-R up: leave said point where it was dragged to.
37
38 ;; Shift-Mouse-M: paste
39
40 ;;;; Interaction to implement:
41
42 ;; Shift-Mouse-L single click: (maybe) select current presentation, if any.
43 ;; Shift-Mouse-L double click: select word
44 ;; Shift-Mouse-L triple click: select "line".
45
46 ;; TODO:
47 ;; * Editor input (both active and old) is not currently highlighted.
48 ;; * Selecting large regions gets slow.
49 ;; * Structure of line breaks in the original text is not preserved (CLIM/McCLIM design issue)
50
51
52 ;;;; Preferences
53
54 (defparameter *marking-border* 1)
55
56 (defparameter *marked-foreground* +white+
57 "Foreground ink to use for marked stuff.")
58
59 (defparameter *marked-background* +blue4+
60 "Background ink to use for marked stuff.")
61
62
63 ;;;; Text Selection Protocol
64
65 (defgeneric release-selection (port &optional time)
66 (:documentation "Relinquish ownership of the selection."))
67
68 (defgeneric request-selection (port requestor time)
69 (:documentation "Request that the window system retrieve the selection from
70 its current owner. This should cause a selection-notify-event to be delivered."))
71
72 (defgeneric bind-selection (port window &optional time)
73 (:documentation "Take ownership of the selection."))
74
75 (defgeneric send-selection (port request-event string)
76 (:documentation "Send 'string' to a client in response to a selection-request-event."))
77
78 (defgeneric get-selection-from-event (port event)
79 (:documentation "Given a selection-notify event, return a string containing
80 the incoming selection."))
81
82 ;; These events are probably very X11 specific.
83
84 ;; Backends will likely produce subclasses of selection-notify-event
85 ;; and selection-request-event.
86
87 (defclass selection-event (window-event)
88 ((selection :initarg :selection
89 :reader selection-event-selection)))
90
91 (defclass selection-clear-event (selection-event) ())
92 (defclass selection-notify-event (selection-event) ())
93 (defclass selection-request-event (selection-event)
94 ((requestor :initarg :requestor :reader selection-event-requestor)))
95
96
97 ;;;; Random Notes
98
99 ;; - McCLIM still has absolutely no idea of lines.
100
101 (defclass marking ()
102 ()
103 (:documentation "A common super class for markings (= stuff marked)."))
104
105 (defgeneric marking-region (stream marking)
106 (:documentation "Region marked/affected."))
107
108 (defclass string-marking (marking)
109 ((record :initarg :record
110 :documentation "The text output record this belongs to.")
111 (styled-string :initarg :styled-string
112 :documentation "The styled string sub-record of 'record'.")
113 (start :initarg :start :reader mark-start
114 :documentation "Start index within string.")
115 (end :initarg :end :reader mark-end
116 :documentation "End index within string. Caution: Could be one off the end to indicate a newline implied."))
117 (:documentation "Some part of a styled-string marked."))
118
119 (defmethod marking-region (stream (marking string-marking))
120 (with-slots (record styled-string start end) marking
121 (with-slots (baseline start-y) record
122 (if (= start end)
123 +nowhere+
124 (with-slots (start-x string text-style) styled-string
125 (make-rectangle* (+ start-x
126 (stream-string-width stream string
127 :start 0 :end start
128 :text-style text-style)
129 (- *marking-border*))
130 (+ start-y baseline
131 (- (text-style-ascent text-style stream))
132 (- *marking-border*))
133 (+ start-x
134 (stream-string-width stream string
135 :start 0 :end end
136 :text-style text-style)
137 *marking-border*)
138 (+ start-y baseline (text-style-descent text-style stream)
139 *marking-border*)))))))
140
141 ;(defgeneric draw-marking (medium marking)
142 ; (:documentation "Draw the marking to medium."))
143 ;
144 ;(defmethod draw-marking (stream (marking string-marking))
145 ; (draw-design (sheet-medium stream) (marking-region marking)
146 ; :ink +flipping-ink+))
147
148 ;;;;
149
150 (defclass cut-and-paste-mixin ()
151 ((markings :initform nil)
152 (point-1-x :initform nil)
153 (point-1-y :initform nil)
154 (point-2-x :initform nil)
155 (point-2-y :initform nil)
156 (dragging-p :initform nil)))
157
158 (defclass paste-as-keypress-mixin ()
159 ()
160 (:documentation "Implements the old McCLIM behavior of pasting via a
161 sequence of key press events. You couldn't possibly want this."))
162
163 (defmethod handle-repaint :around ((pane cut-and-paste-mixin) region)
164 (with-slots (markings) pane
165 (cond ((null markings)
166 (call-next-method))
167 (t
168 (let ((marked-region
169 (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) (slot-value pane 'markings))
170 :initial-value +nowhere+)))
171 (with-sheet-medium (medium pane)
172 (let ((R (region-difference region marked-region)))
173 (with-drawing-options (medium :clipping-region R)
174 (call-next-method pane R))))
175 (with-sheet-medium (medium pane)
176 (let ((R (region-intersection region marked-region)))
177 (with-drawing-options (medium :clipping-region R)
178 (letf (((medium-foreground medium) *marked-foreground*)
179 ((medium-background medium) *marked-background*))
180 (call-next-method pane R))))))))))
181
182 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
183 (event pointer-button-press-event))
184 (if (eql (event-modifier-state event) +shift-key+)
185 (eos/shift-click pane event)
186 (call-next-method)))
187
188 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
189 (event pointer-button-release-event))
190 (if (eql (event-modifier-state event) +shift-key+)
191 (eos/shift-release pane event)
192 (call-next-method)))
193
194 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
195 (event pointer-motion-event))
196 (with-slots (point-1-x dragging-p) pane
197 (if (and (eql (event-modifier-state event) +shift-key+))
198 (when dragging-p (eos/shift-drag pane event))
199 (call-next-method))))
200
201
202 (defun pane-clear-markings (pane &optional time)
203 (repaint-markings pane (slot-value pane 'markings)
204 (setf (slot-value pane 'markings) nil))
205 (release-selection (port pane) time))
206
207
208 (defmethod eos/shift-click ((pane extended-output-stream) event)
209 (with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane
210 (cond ((eql +pointer-left-button+ (pointer-event-button event))
211 (pane-clear-markings pane (event-timestamp event))
212 ;; start dragging, set point-1 where the mouse is
213 (setf point-1-x (pointer-event-x event))
214 (setf point-1-y (pointer-event-y event))
215 (setf dragging-p t))
216 ((eql +pointer-middle-button+ (pointer-event-button event))
217 ;; paste
218 (request-selection (port pane) #|:UTF8_STRING|# (sheet-direct-mirror pane) (event-timestamp event)))
219 ((eql +pointer-right-button+ (pointer-event-button event))
220 (when (and point-1-x point-1-y point-2-x point-2-y)
221 ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around.
222 (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2)
223 (expt (- (pointer-event-y event) point-1-y) 2))
224 (+ (expt (- (pointer-event-x event) point-2-x) 2)
225 (expt (- (pointer-event-y event) point-2-y) 2)))
226 (rotatef point-1-x point-2-x)
227 (rotatef point-1-y point-2-y))
228 (eos/shift-drag pane event)
229 (setf dragging-p t)))
230 (t (describe event)))))
231
232 (defmethod eos/shift-release ((pane extended-output-stream) event)
233 (with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane
234 (when dragging-p
235 (setf point-2-x (pointer-event-x event)
236 point-2-y (pointer-event-y event)
237 dragging-p nil)
238 ;;
239 (let ((owner (selection-owner (port pane))))
240 (when (and owner (not (eq owner pane)))
241 (distribute-event (port pane)
242 (make-instance 'selection-clear-event
243 :sheet owner
244 :selection :primary))))
245 (when (bind-selection (port pane) pane (event-timestamp event))
246 (setf (selection-owner (port pane)) pane)
247 (setf (selection-timestamp (port pane)) (event-timestamp event))))))
248
249 (defun repaint-markings (pane old-markings new-markings)
250 (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings)
251 :initial-value +nowhere+))
252 (new-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) new-markings)
253 :initial-value +nowhere+)))
254 (handle-repaint pane (region-exclusive-or old-region new-region))))
255
256 (defmethod eos/shift-drag ((pane extended-output-stream) event)
257 (with-slots (point-1-x point-1-y) pane
258 (let ((old-markings (slot-value pane 'markings)))
259 (setup-marked-extents pane (stream-output-history pane) +everywhere+
260 point-1-x point-1-y
261 (pointer-event-x event)
262 (pointer-event-y event))
263 (repaint-markings pane old-markings (slot-value pane 'markings)))))
264
265 (defun map-over-text (record function)
266 (cond ((typep record 'standard-text-displayed-output-record)
267 (with-slots (strings baseline max-height start-y wrapped x1 y1) record
268 (loop for substring in strings do
269 (with-slots (start-x string marked-extent text-style) substring
270 (funcall function start-x (+ start-y baseline) string text-style
271 substring record)))))
272 (t
273 (map-over-output-records-overlapping-region
274 #'(lambda (x)
275 (map-over-text x function))
276 record +everywhere+))))
277
278 (defun setup-marked-extents (stream record region bx1 by1 bx2 by2)
279 (declare (ignore region))
280 (when (> by1 by2)
281 (rotatef by1 by2)
282 (rotatef bx1 bx2))
283 (let ((*lines* nil)
284 (*all-lines* nil))
285 (map-over-text record
286 (lambda (x y string ts record full-record)
287 (let ((q (assoc y *lines*)))
288 (unless q
289 (push (setf q (cons y nil)) *lines*))
290 (push (list x y string ts record full-record)
291 (cdr q)))
292 (force-output *trace-output*)))
293 (setf *lines*
294 (sort (mapcar (lambda (line)
295 (cons (car line)
296 (sort (cdr line) #'< :key #'first)))
297 *lines*)
298 #'< :key #'car))
299 (setf *all-lines* *lines*)
300 ;; Nuke every line that is above by1
301 (setf *lines* (remove-if (lambda (line) (< (+ (car line) 3) by1)) *lines*))
302 ;; Also nuke all that are below by2
303 (setf *lines* (remove-if (lambda (line) (> (- (car line) 10) by2)) *lines*))
304 ;; Special case:
305 (when (= 1 (length *lines*))
306 (psetf bx1 (min bx1 bx2)
307 bx2 (max bx1 bx2)))
308 ;; Then, in the first line find the index farthest to the right
309 ;; which is still less than bx1.
310 (let ((start-i 0)
311 (start-record (fifth (cadar *lines*)))
312 (end-i 0)
313 (end-record (fifth (cadar (last *lines*)))))
314
315 (loop for chunk in (cdr (first *lines*)) do
316 (destructuring-bind (x y string ts record full-record) chunk
317 (declare (ignorable x y string ts record full-record))
318 (loop for i to (length string) do
319 (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
320 bx1)
321 (setf start-i i
322 start-record record)))))
323
324 ;; Finally in the last line find the index farthest to the left
325 ;; which still is greater than bx2. Or put differently: Search
326 ;; from the left and while we are still in bounds maintain end-i
327 ;; and end-record.
328 (loop for chunk in (cdr (car (last *lines*))) do
329 (destructuring-bind (x y string ts record full-record) chunk
330 (declare (ignorable x y string ts record full-record))
331 (loop for i to (length string) do
332 (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
333 bx2)
334 (setf end-i i
335 end-record record)))))
336
337 ;; Now grovel over the records, in order ...
338 (let ((in-p nil)
339 (marks nil))
340 (labels ((visit (chunk)
341 (destructuring-bind (x y string ts record full-record) chunk
342 (declare (ignorable x y string ts record full-record))
343 (let ((marked-extent nil))
344 (cond ((eq record start-record)
345 (cond ((eq record end-record)
346 (setf marked-extent
347 (cons start-i end-i)))
348 (t
349 (setf marked-extent
350 (cons start-i (length string)))
351 (setf in-p t))))
352 ((eq record end-record)
353 (setf marked-extent
354 (cons 0 end-i))
355 (setf in-p nil))
356 (t
357 (setf marked-extent
358 (if in-p
359 (cons 0 (length string))
360 nil))) )
361 (when marked-extent
362 (push (destructuring-bind (x y string ts record full-record) chunk
363 (declare (ignorable x y string ts record full-record))
364 (make-instance 'string-marking
365 :record full-record
366 :styled-string record
367 :start (car marked-extent)
368 :end (cdr marked-extent)))
369 marks)) ))))
370 (loop for line in *all-lines* do
371 (loop for chunk in (cdr line) do
372 (visit chunk)) )
373 (setf (slot-value stream 'markings) (reverse marks)))))))
374
375
376 ;;;; Selections Events
377
378 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
379 (event selection-clear-event))
380 (pane-clear-markings pane (event-timestamp event)))
381
382 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
383 (event selection-request-event))
384 (send-selection (port pane) event (fetch-selection pane)))
385
386 (define-condition selection-notify ()
387 ((event :reader event-of :initarg :event)))
388
389 (defmethod handle-event ((pane cut-and-paste-mixin)
390 (event selection-notify-event))
391 (signal 'selection-notify :event event))
392
393 (defmethod dispatch-event :around ((pane paste-as-keypress-mixin)
394 (event selection-notify-event))
395 (let ((matter (get-selection-from-event (port pane) event)))
396 (loop for c across matter do
397 (dispatch-event pane
398 (make-instance 'key-press-event
399 :timestamp (event-timestamp event)
400 :sheet pane
401 :modifier-state 0
402 :x 0 :y 0 :graft-x 0 :graft-y 0
403 :key-name nil
404 :key-character c)))))
405
406
407 ;; FIXME: Non-text target conversions.. (?)
408 (defun fetch-selection (pane)
409 (let (old-y2 old-x2)
410 (with-output-to-string (bag)
411 (map nil
412 (lambda (m)
413 (with-slots (record styled-string start end) m
414 (with-standard-rectangle*
415 (:x1 x1 :x2 x2 :y1 y1 :y2 y2) record
416 (cond ((and old-y2 (>= y1 old-y2))
417 (setf old-y2 nil
418 old-x2 0 ;<-- ### we should use the minimum of all x1 coordinates.
419 )
420 (terpri bag))
421 (t
422 (setf old-y2 (max y2 (or old-y2 y2)))))
423 (when old-x2
424 (loop repeat (round
425 (- x1 old-x2)
426 (text-style-width (slot-value styled-string 'text-style)
427 pane))
428 do
429 (princ " " bag)))
430 (setf old-x2 x2)
431 (princ (subseq (styled-string-string styled-string) start end) bag))))
432 (slot-value pane 'markings)))))

  ViewVC Help
Powered by ViewVC 1.1.5