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

Contents of /mcclim/text-selection.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide 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 hefner1 1.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 ahefner 1.8 ;;;; Text Selection Protocol
64 hefner1 1.1
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 ahefner 1.5 (defgeneric send-selection (port request-event string)
76 hefner1 1.1 (:documentation "Send 'string' to a client in response to a selection-request-event."))
77    
78 ahefner 1.5 (defgeneric get-selection-from-event (port event)
79 hefner1 1.1 (: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 ahefner 1.8 (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 hefner1 1.1
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 ahefner 1.8 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
183 hefner1 1.1 (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 ahefner 1.8 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
189 hefner1 1.1 (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 ahefner 1.8 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
195 hefner1 1.1 (event pointer-motion-event))
196     (with-slots (point-1-x dragging-p) pane
197     (if (and (eql (event-modifier-state event) +shift-key+))
198 ahefner 1.8 (when dragging-p (eos/shift-drag pane event))
199 hefner1 1.1 (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 ahefner 1.2 (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 hefner1 1.1 (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 crhodes 1.3 (when (bind-selection (port pane) pane (event-timestamp event))
246 crhodes 1.6 (setf (selection-owner (port pane)) pane)
247     (setf (selection-timestamp (port pane)) (event-timestamp event))))))
248 hefner1 1.1
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 ahefner 1.8 (map-over-text record
286 hefner1 1.1 (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 gbaumann 1.9 (force-output *trace-output*)))
293 hefner1 1.1 (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 ahefner 1.8 ;; 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 hefner1 1.1 (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 ahefner 1.8 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
379 ahefner 1.5 (event selection-clear-event))
380 hefner1 1.1 (pane-clear-markings pane (event-timestamp event)))
381    
382 ahefner 1.8 (defmethod dispatch-event :around ((pane cut-and-paste-mixin)
383 ahefner 1.5 (event selection-request-event))
384     (send-selection (port pane) event (fetch-selection pane)))
385 hefner1 1.1
386 ahefner 1.8 (define-condition selection-notify ()
387     ((event :reader event-of :initarg :event)))
388 hefner1 1.1
389 ahefner 1.8 (defmethod handle-event ((pane cut-and-paste-mixin)
390     (event selection-notify-event))
391     (signal 'selection-notify :event event))
392 hefner1 1.1
393 ahefner 1.8 (defmethod dispatch-event :around ((pane paste-as-keypress-mixin)
394 hefner1 1.1 (event selection-notify-event))
395 ahefner 1.5 (let ((matter (get-selection-from-event (port pane) event)))
396 hefner1 1.1 (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 gbaumann 1.7 (let (old-y2 old-x2)
410 hefner1 1.1 (with-output-to-string (bag)
411     (map nil
412     (lambda (m)
413     (with-slots (record styled-string start end) m
414 gbaumann 1.7 (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 hefner1 1.1 (slot-value pane 'markings)))))

  ViewVC Help
Powered by ViewVC 1.1.5