root/trunk/lisp/nzwei/mouse.lisp @ 257

Revision 257, 17.9 KB (checked in by rjs, 3 years ago)

Initial versions.

Line 
1;;; Mouse commands for ZWEI -*-Mode:LISP;Package:ZWEI-*-
2;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
3;;; Note: some screen system primitives live in SCREEN
4
5;;; Proposed mouse command table for ZWEI windows:
6;;;  [1] Mark some characters.
7;;;  [11] No region -> Select window, Region -> You are moving it.
8;;;  [2] Mark some things.
9;;;  [22] Kill, Yank, Yank-pop
10;;;  [3] Put ZWEI menu here.
11;;;  [33] Call system menu
12
13(DEFVAR *MOUSE-P*)
14(DEFVAR *MOUSE-CHAR-BLINKER*)
15(DEFVAR *GLOBAL-MOUSE-CHAR-BLINKER*)
16(DEFVAR *GLOBAL-MOUSE-CHAR-BLINKER-HANDLER*)
17
18;;; Called by the editor to initialize the mouse
19(DEFUN INITIALIZE-MOUSE (&AUX (INHIBIT-SCHEDULING-FLAG T))
20  (AND (BOUNDP '*MOUSE-CHAR-BLINKER*)
21       (TV:OPEN-BLINKER *MOUSE-CHAR-BLINKER*))
22  (SETQ *MOUSE-P* NIL
23        *MOUSE-CHAR-BLINKER* (TV:DEFINE-BLINKER TV:MOUSE-SHEET 'TV:CHARACTER-BLINKER
24                                                ':VISIBILITY NIL
25                                                ':HALF-PERIOD 4
26                                                ':FONT TV:(SCREEN-DEFAULT-FONT DEFAULT-SCREEN)
27                                                ':CHAR #/?)
28        *GLOBAL-MOUSE-CHAR-BLINKER* (TV:DEFINE-BLINKER TV:MOUSE-SHEET 'TV:RECTANGULAR-BLINKER
29                                                       ':VISIBILITY NIL
30                                                       ':HALF-PERIOD 4)
31        *GLOBAL-MOUSE-CHAR-BLINKER-HANDLER* NIL))
32
33;;;Wait for the mouse to do something, return non-nil if released buttons or left window
34(DEFUN WAIT-FOR-MOUSE (LAST-X LAST-Y &OPTIONAL MAX-SPEED)
35  (PROCESS-WAIT "MOUSE"
36                #'(LAMBDA (LX LY MS)
37                    (OR (AND (OR ( TV:MOUSE-X LX) ( TV:MOUSE-Y LY))
38                             (OR (NULL MS) ( TV:MOUSE-SPEED MS)))
39                        (ZEROP TV:MOUSE-LAST-BUTTONS)
40                        (NOT *MOUSE-P*)))
41                LAST-X LAST-Y MAX-SPEED)
42  (AND (NOT (ZEROP TV:MOUSE-LAST-BUTTONS)) *MOUSE-P*))
43
44;;; Call MOUSE-CHAR so we can be sure that the BP points the thing that's blinking
45(DEFUN MOUSE-BP (WINDOW &AUX CHAR X Y LINE CHAR-POS)
46  (MULTIPLE-VALUE (CHAR X Y LINE CHAR-POS)
47    (MOUSE-CHAR WINDOW))
48  (COND ((NULL CHAR)      ;Couldn't anything, use end of buffer for want of anything better
49         (COPY-BP (INTERVAL-LAST-BP (WINDOW-INTERVAL WINDOW))))
50        (T
51         (CREATE-BP LINE CHAR-POS))))
52
53;;; The mouse must be in the selected window's area of the screen
54;;; Returns the character at which the mouse points, and the X and Y positions
55;;; of that character relative to its sheet.  If the mouse is not at a character,
56;;; returns NIL.
57(DEFUN MOUSE-CHAR (WINDOW)
58  (PROG (SHEET LINE PLINE CHAR-POS LH X Y REAL-PLINE START END)
59    (SETQ SHEET (WINDOW-SHEET WINDOW))
60    (MULTIPLE-VALUE (X Y)
61      (TV:SHEET-CALCULATE-OFFSETS SHEET TV:MOUSE-SHEET))
62    (SETQ LH (TV:SHEET-LINE-HEIGHT SHEET)
63          PLINE (SETQ REAL-PLINE (// (- TV:MOUSE-Y Y) LH)))
64    ;; If mouse moves to out of range, protect against error and return
65    (AND (OR (MINUSP PLINE) ( PLINE (WINDOW-N-PLINES WINDOW)))
66         (RETURN NIL))
67    (DO NIL ((AND (PLINE-LINE WINDOW PLINE)
68                  (ZEROP (PLINE-FROM-INDEX WINDOW PLINE))))
69      (AND (ZEROP PLINE) (RETURN))
70      (SETQ PLINE (1- PLINE)))
71    (OR (SETQ LINE (PLINE-LINE WINDOW PLINE))
72        (RETURN))
73    (SETQ START (PLINE-FROM-INDEX WINDOW PLINE))
74    (LET ((BP (INTERVAL-FIRST-BP (WINDOW-INTERVAL WINDOW))))
75      (AND (EQ LINE (BP-LINE BP)) (SETQ START (MIN START (BP-INDEX BP)))))
76    (LET ((BP (INTERVAL-LAST-BP (WINDOW-INTERVAL WINDOW))))
77      (AND (EQ LINE (BP-LINE BP)) (SETQ END (BP-INDEX BP))))
78    (MULTIPLE-VALUE (X Y CHAR-POS)         ;Find character to right of mouse
79      (TV:SHEET-COMPUTE-MOTION SHEET 0 (* PLINE LH) LINE START END NIL
80                               (MAX 0 (- TV:MOUSE-X X))
81                               (* REAL-PLINE LH)))
82    (COND ((NULL CHAR-POS)                      ;Mouse if off end of line, pointing at the CR
83           (RETURN #\CR X Y LINE (OR END (LINE-LENGTH LINE))))
84          (T
85           ;; X, Y, CHAR-POS are for char to right of mouse
86           ;; Find the character which is just over the mouse
87           (SETQ CHAR-POS (MAX 0 (1- CHAR-POS)))
88           (LET ((CHAR (IF (= CHAR-POS (LINE-LENGTH LINE)) #\CR
89                           (AREF LINE CHAR-POS)))
90                 (FONT-MAP (TV:SHEET-FONT-MAP SHEET)))
91              (LET ((FONT (AREF FONT-MAP (LDB %%CH-FONT CHAR))))
92                (RETURN CHAR
93                        (MAX 0
94                             (- X (TV:SHEET-CHARACTER-WIDTH SHEET (LDB %%CH-CHAR CHAR) FONT)))
95                        (+ Y (- (TV:SHEET-BASELINE SHEET) (FONT-BASELINE FONT)))
96                        LINE CHAR-POS)))))))
97
98;;; This returns the name of a function, either from the buffer with the mouse, or the
99;;; mini-buffer.
100;;; STRINGP of T means return a string if one is typed, don't intern it now.
101;;; STRINGP of ALWAYS-READ means always return a newly read symbol, even if a completion
102;;; was typed.
103(DEFUN READ-FUNCTION-NAME (PROMPT &OPTIONAL DEFAULT MUST-BE-DEFINED STRINGP
104                                  &AUX TEM CH)
105  (AND (EQ MUST-BE-DEFINED T) (SETQ STRINGP 'ALWAYS-READ))
106  (SETQ PROMPT (FORMAT NIL "~A~:[:~; (Default: ~S)~]" PROMPT DEFAULT DEFAULT))
107  (COND ((OR *MINI-BUFFER-REPEATED-COMMAND* (FUNCALL STANDARD-INPUT ':LISTEN))
108         (SETQ TEM 0 CH NIL))                   ;C-X , no opportunity for mouse
109        (T
110         (LET ((*MODE-LINE-LIST* (NCONS PROMPT)))
111           (REDISPLAY-MODE-LINE))               ;Make correct for later
112         (DELETE-INTERVAL (WINDOW-INTERVAL *MINI-BUFFER-WINDOW*))
113         (MUST-REDISPLAY *MINI-BUFFER-WINDOW* DIS-ALL)
114         (SELECT-WINDOW *MINI-BUFFER-WINDOW*)
115         ;;KLUDGE, position blinker
116         (DO L (WINDOW-SPECIAL-BLINKER-LIST *MINI-BUFFER-WINDOW*) (CDR L) (NULL L)
117           (TV:BLINKER-SET-VISIBILITY (CDAR L) NIL))
118         (LET ((BL (WINDOW-POINT-BLINKER *MINI-BUFFER-WINDOW*)))
119           (TV:BLINKER-SET-CURSORPOS BL 0 0)
120           (TV:BLINKER-SET-VISIBILITY BL ':BLINK))
121         (UNWIND-PROTECT
122           (LET-GLOBALLY ((*GLOBAL-MOUSE-CHAR-BLINKER-HANDLER* (IF MUST-BE-DEFINED
123                                                                   #'BLINK-FUNCTION
124                                                                   #'BLINK-ATOM))
125                          (*MOUSE-FONT-CHAR* 0)
126                          (*MOUSE-X-OFFSET* 4)
127                          (*MOUSE-Y-OFFSET* 0))
128             (SETQ TV:MOUSE-RECONSIDER T)
129             (MULTIPLE-VALUE (TEM CH)
130               (FUNCALL STANDARD-INPUT ':MOUSE-OR-KBD-TYI)))
131           (TV:BLINKER-SET-VISIBILITY *GLOBAL-MOUSE-CHAR-BLINKER* NIL)
132           (SETQ TV:MOUSE-RECONSIDER T))))
133  (COND ((AND (= TEM #\MOUSE-1-1) (OR (FBOUNDP (SETQ TEM (ATOM-UNDER-MOUSE (CADR CH))))
134                                      (STRING-IN-AARRAY-P TEM *ZMACS-COMPLETION-AARRAY*)
135                                      (GET TEM ':SOURCE-FILE-NAME)
136                                      (AND (NOT MUST-BE-DEFINED) TEM)))
137         (SELECT-WINDOW *WINDOW*)
138         (DISAPPEAR-MINI-BUFFER-WINDOW) 
139         TEM)
140        (T
141         (FUNCALL STANDARD-INPUT ':UNTYI CH)
142         (LET ((NAME (COMPLETING-READ-FROM-MINI-BUFFER PROMPT *ZMACS-COMPLETION-AARRAY*
143                                                       (OR (NEQ STRINGP 'ALWAYS-READ)
144                                                           'ALWAYS-STRING)))
145               SYM)
146           (COND ((EQUAL NAME "")
147                  (OR DEFAULT (BARF))
148                  (SETQ SYM DEFAULT NAME (STRING DEFAULT)))
149                 ((LISTP NAME)
150                  (SETQ SYM (CDR NAME)
151                        NAME (CAR NAME)))
152                 ((EQ STRINGP T)                ;If returning a string, don't intern it
153                  (SETQ SYM NAME))
154                 (T
155                  (MULTIPLE-VALUE (SYM NAME)
156                                  (SYMBOL-FROM-STRING NAME))))
157           (AND (EQ MUST-BE-DEFINED T) (NOT (FDEFINEDP SYM)) (BARF "~S is not defined" SYM))
158           (MVRETURN SYM NAME)))))
159
160;;; This finds the atom the mouse is pointing to
161(DEFUN ATOM-UNDER-MOUSE (WINDOW &OPTIONAL CHAR X Y LINE INDEX &AUX SYMBOL END)
162  (OR CHAR (MULTIPLE-VALUE (CHAR X Y LINE INDEX)
163               (MOUSE-CHAR WINDOW)))
164  (AND CHAR
165       ( CHAR #\CR)
166       (DO ((I INDEX (1- I)))
167           ((OR (ZEROP I)
168                ( (ATOM-WORD-SYNTAX (AREF LINE I)) WORD-ALPHABETIC))
169            (AND ( I INDEX)
170                 (ERRSET (LET ((PACKAGE PACKAGE)
171                               (READ-PRESERVE-DELIMITERS T)
172                               (INTERVAL (WINDOW-INTERVAL WINDOW)))
173                           (AND (ZMACS-BUFFER-P INTERVAL BUFFER-FILE-GROUP-SYMBOL)
174                                (COMPUTE-BUFFER-PACKAGE INTERVAL))
175                           (MULTIPLE-VALUE (SYMBOL END)
176                               (READ-FROM-STRING LINE NIL (SETQ I (1+ I))))
177                           (SETQ END (MIN (ARRAY-ACTIVE-LENGTH LINE) END)))
178                         NIL)
179                 (SYMBOLP SYMBOL)
180                 (MVRETURN SYMBOL I END))))))
181
182;;; This blinks functions that you point to
183(DEFVAR *BLINKING-FUNCTION-MAXIMUM-MOUSE-SPEED* 0.5s0)
184(DEFUN BLINK-FUNCTION (BLINKER WINDOW CHAR X Y LINE INDEX &OPTIONAL NOT-DEFINED-OK
185                                                          &AUX SYMBOL BEG END SHEET)
186  (COND ((> TV:MOUSE-SPEED *BLINKING-FUNCTION-MAXIMUM-MOUSE-SPEED*)
187         (TV:BLINKER-SET-VISIBILITY BLINKER NIL))       ;Moving too fast, forget it
188        (T
189         (MULTIPLE-VALUE (SYMBOL BEG END)
190           (ATOM-UNDER-MOUSE WINDOW CHAR X Y LINE INDEX))
191         (COND ((AND (NOT (NULL BEG))
192                     (OR (FBOUNDP SYMBOL)
193                         (STRING-IN-AARRAY-P SYMBOL *ZMACS-COMPLETION-AARRAY*)
194                         (GET SYMBOL 'SOURCE-FILE-NAME)
195                         NOT-DEFINED-OK))
196                (SETQ SHEET (WINDOW-SHEET WINDOW))
197                (TV:BLINKER-SET-SHEET BLINKER SHEET)
198                (SHEET-SET-BLINKER-CURSORPOS SHEET BLINKER
199                                             (- X (* (TV:SHEET-CHAR-WIDTH SHEET)
200                                                     (- INDEX BEG)))
201                                             Y)
202                (TV:BLINKER-SET-SIZE BLINKER
203                                     (TV:SHEET-STRING-LENGTH SHEET LINE BEG END)
204                                     (FONT-CHAR-HEIGHT (AREF (TV:SHEET-FONT-MAP SHEET)
205                                                             (LDB %%CH-FONT CHAR))))
206                (TV:BLINKER-SET-VISIBILITY BLINKER T))
207               (T
208                (TV:BLINKER-SET-VISIBILITY BLINKER NIL))))))
209
210(DEFUN BLINK-ATOM (BLINKER WINDOW CHAR X Y LINE INDEX)
211  (BLINK-FUNCTION BLINKER WINDOW CHAR X Y LINE INDEX T))
212
213;;; The commands themselves
214
215;;; Single click on the left button.
216(DEFCOM COM-MOUSE-MARK-REGION "Jump point and mark to where the mouse is.
217Then as the mouse is moved with the button held down point follows the mouse." (KM)
218  (REDISPLAY *WINDOW* ':NONE)
219  (FUNCALL (WINDOW-SHEET *WINDOW*) ':SET-MOUSE-POSITION *MOUSE-X* *MOUSE-Y*)
220  (LET ((POINT (POINT))
221        (MARK (MARK))
222        (OLD-REGION-P (WINDOW-MARK-P *WINDOW*))
223        (BP (MOUSE-BP *WINDOW*)))
224    (MOVE-BP MARK BP)
225    (SETF (WINDOW-MARK-P *WINDOW*) T)
226    (DO ((LAST-X TV:MOUSE-X TV:MOUSE-X)
227         (LAST-Y TV:MOUSE-Y TV:MOUSE-Y))
228        (NIL)
229        (MOVE-BP POINT BP)
230        (MUST-REDISPLAY *WINDOW* DIS-BPS)
231        (REDISPLAY *WINDOW* ':POINT)
232        (OR (WAIT-FOR-MOUSE LAST-X LAST-Y) (RETURN NIL))
233        (SETQ BP (MOUSE-BP *WINDOW*)))
234    (AND (BP-= POINT MARK)
235         (SETF (WINDOW-MARK-P *WINDOW*) OLD-REGION-P)))
236    DIS-NONE)
237
238(DEFCOM COM-MOUSE-MOVE-REGION "Select window, or adjust the region.
239If there is a region, jump the mouse to point or mark (whichever
240is closer), and move it with the mouse as long as the button is
241held down.  If there is no region, select the window without
242affecting point (or mark)." (KM)
243  (LET ((SHEET (WINDOW-SHEET *WINDOW*))
244        PX PY MX MY BP BP1 XOFF YOFF)
245    (MULTIPLE-VALUE (MX MY)
246        (FIND-BP-IN-WINDOW-COORDS (MARK) *WINDOW*))
247    (MULTIPLE-VALUE (PX PY)
248        (FIND-BP-IN-WINDOW-COORDS (POINT) *WINDOW*))
249    (MULTIPLE-VALUE (XOFF YOFF)
250        (TV:SHEET-CALCULATE-OFFSETS SHEET TV:MOUSE-SHEET))
251    (SETQ BP (COND ((NOT (AND (WINDOW-MARK-P *WINDOW*) MX)) (POINT))
252                   ((LET ((X (- TV:MOUSE-X XOFF))
253                          (Y (- TV:MOUSE-Y YOFF)))
254                      (< (+ (^ (ABS (- X PX)) 2) (^ (ABS (- Y PY)) 2))
255                         (+ (^ (ABS (- X MX)) 2) (^ (ABS (- Y MY)) 2))))
256                    (POINT))
257                   (T
258                    (SETQ PX MX PY MY)
259                    (MARK))))
260    (FUNCALL SHEET ':SET-MOUSE-POSITION PX (+ PY (// (* 3 (TV:SHEET-LINE-HEIGHT SHEET)) 4)))
261    (DO ((LAST-X TV:MOUSE-X TV:MOUSE-X)
262         (LAST-Y TV:MOUSE-Y TV:MOUSE-Y))
263        (NIL)
264      (OR (WAIT-FOR-MOUSE LAST-X LAST-Y) (RETURN NIL))
265      (SETQ BP1 (MOUSE-BP *WINDOW*))
266      (MOVE-BP BP BP1)
267      (MUST-REDISPLAY *WINDOW* DIS-BPS)
268      (REDISPLAY *WINDOW* ':POINT)))
269  DIS-NONE)
270
271(DEFCOM COM-MOUSE-MARK-THING "Mark the thing you are pointing at." (SM)
272  (FUNCALL (WINDOW-SHEET *WINDOW*) ':SET-MOUSE-POSITION *MOUSE-X* *MOUSE-Y*)
273  (DO ((POINT (POINT))
274       (MARK (MARK))
275       (LAST-X TV:MOUSE-X TV:MOUSE-X)
276       (LAST-Y TV:MOUSE-Y TV:MOUSE-Y)
277       (CHAR) (X) (Y)
278       (LINE) (CHAR-POS)
279       (OL) (OCP))
280      (NIL)
281      (MULTIPLE-VALUE (CHAR X Y LINE CHAR-POS)
282          (MOUSE-CHAR *WINDOW*))                        ;Figure out where mouse it
283      (COND ((AND CHAR (OR (NEQ LINE OL) ( CHAR-POS OCP)))
284             (SETQ OL LINE OCP CHAR-POS)
285             (MOVE-BP POINT LINE CHAR-POS)
286             (FUNCALL (SELECTQ *MAJOR-MODE*
287                        (LISP-MODE 'LISP-MARK-THING)
288                        ((TEXT-MODE FUNDAMENTAL-MODE BOLIO-MODE) 'TEXT-MARK-THING)
289                        (OTHERWISE 'DEFAULT-MARK-THING))
290                      POINT MARK CHAR LINE CHAR-POS)
291             (MUST-REDISPLAY *WINDOW* DIS-BPS)
292             (REDISPLAY *WINDOW* ':POINT)))
293      (OR (WAIT-FOR-MOUSE LAST-X LAST-Y) (RETURN NIL)))
294  DIS-NONE)
295
296(DEFUN LISP-MARK-THING (POINT MARK CHAR LINE CHAR-POS)
297  (ATOM-WORD-SYNTAX-BIND
298    (SELECT (LIST-SYNTAX CHAR)
299      ((LIST-OPEN LIST-SINGLE-QUOTE)
300       (MOVE-BP MARK (FORWARD-SEXP POINT 1 T)))
301      (LIST-CLOSE
302       (MOVE-BP POINT (FORWARD-CHAR POINT 1))
303       (MOVE-BP MARK (FORWARD-SEXP POINT -1 T)))
304      (LIST-DOUBLE-QUOTE
305       (COND ((LISP-BP-SYNTACTIC-CONTEXT POINT)
306              (MOVE-BP POINT (FORWARD-CHAR POINT 1 T))
307              (MOVE-BP MARK (FORWARD-SEXP POINT -1)))
308             (T
309              (MOVE-BP MARK (FORWARD-SEXP POINT 1 T)))))
310      (LIST-COMMENT
311       (MOVE-BP POINT (BACKWARD-OVER *BLANKS* POINT))
312       (MOVE-BP MARK LINE (LINE-LENGTH LINE)))
313      (OTHERWISE
314       (DEFAULT-MARK-THING POINT MARK CHAR LINE CHAR-POS)))))
315
316(DEFUN TEXT-MARK-THING (POINT MARK CHAR LINE CHAR-POS)
317  (COND ((MEMQ CHAR '(#/. #/? #/!))
318         (MOVE-BP POINT (FORWARD-CHAR POINT 1))
319         (MOVE-BP MARK (FORWARD-SENTENCE POINT -1 T)))
320        ((MEMQ CHAR '(#/: #/; #/,))
321         (MOVE-BP MARK (FORWARD-OVER *BLANKS* (FORWARD-CHAR
322                                               (SEARCH-SET POINT
323                                                           (IF (= CHAR #/,)
324                                                               '(#/. #/? #/! #/: #/; #/,)
325                                                               '(#/, #/? #/! #/: #/;))
326                                                           T T)
327                                               1 T)))
328         (MOVE-BP POINT (FORWARD-CHAR POINT 1)))
329        (T
330         (DEFAULT-MARK-THING POINT MARK CHAR LINE CHAR-POS))))
331
332(DEFUN DEFAULT-MARK-THING (POINT MARK CHAR LINE CHAR-POS &AUX TEM)
333  (COND ((= CHAR #\FF)
334         (MOVE-BP MARK (FORWARD-PAGE POINT -1 T)))
335        ((MEMQ CHAR '(#\SP #\TAB))
336         (COND ((STRING-REVERSE-SEARCH-NOT-SET *BLANKS* LINE CHAR-POS)
337                (MOVE-BP MARK (FORWARD-WORD POINT 1 T)))
338               (T
339                (MOVE-BP POINT LINE 0)
340                (MOVE-BP MARK LINE (LINE-LENGTH LINE)))))
341        ((= CHAR #\CR)
342         (MOVE-BP MARK LINE 0))
343        ((SETQ TEM (ASSOC CHAR '((#/( . #/)) (#/[ . #/]) (#/< . #/>) (#/{ . #/}))))
344         (MOVE-BP MARK (SEARCH POINT (CDR TEM) NIL T)))
345        ((SETQ TEM (RASSOC CHAR '((#/( . #/)) (#/[ . #/]) (#/< . #/>) (#/{ . #/}))))
346         (MOVE-BP POINT (FORWARD-CHAR POINT 1 T))
347         (MOVE-BP MARK (SEARCH POINT (CAR TEM) T T)))
348        (T
349         (MOVE-BP MARK (FORWARD-WORD POINT 1 T))
350         (MOVE-BP POINT (FORWARD-WORD MARK -1 T))
351         ;; Now try to attach the right whitespace to the word
352         (LET ((BP (FORWARD-OVER *BLANKS* MARK)))
353           (COND ((NOT (BP-= BP MARK))
354                  (MOVE-BP MARK BP))
355                 (T
356                  (SETQ BP (BACKWARD-OVER *BLANKS* POINT))
357                  (OR (ZEROP (BP-INDEX BP)) (MOVE-BP POINT BP))))))))
358
359(DEFCOM COM-MOUSE-KILL-YANK "Kill region, unkill, or unkill pop.
360If there is a region, save it; if it was saved last time, kill it;
361else if the last command was an unkill, do unkill-pop, else unkill." ()
362  (COND ((EQ *LAST-COMMAND-TYPE* 'SAVE)
363         (DELETE-INTERVAL (POINT) (MARK))
364         DIS-TEXT)
365        ((WINDOW-MARK-P *WINDOW*)
366         (SETQ *CURRENT-COMMAND-TYPE* 'SAVE)
367         (COM-SAVE-REGION))
368        ((EQ *LAST-COMMAND-TYPE* 'YANK)
369         (COM-YANK-POP))
370        (T
371         (COM-YANK))))
372
373;;; This is on mouse-left in the mini-buffer, exit if you are pointing in it, else
374;;; do the standard thing
375(DEFCOM COM-MOUSE-END-OF-MINI-BUFFER "Finish up the mini-buffer command" ()
376  (COND ((NEQ *WINDOW* *MINI-BUFFER-WINDOW*)
377         (COMMAND-EXECUTE (COMMAND-LOOKUP 2000 *STANDARD-COMTAB*) 2000))
378        (T
379         (KEY-EXECUTE #\CR))))
380
381;;; This is on mouse-right in the completing-reader, give a menu of the possibilities
382(DEFCOM COM-MOUSE-LIST-COMPLETIONS "Give a menu of possible completions" ()
383  (MULTIPLE-VALUE-BIND (NIL POSS)
384      (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*)
385      (OR POSS (BARF))
386      (LET ((CHOICE (TV:MENU-CHOOSE POSS)))
387        (COND (CHOICE
388               (*THROW 'RETURN-FROM-COMMAND-LOOP CHOICE))
389              (T
390               DIS-NONE)))))
391
392(DEFCOM COM-MOUSE-INDENT-RIGIDLY "Track indentation with the mouse.
393If there is a region, moves the whole region, else the current line.  Continues until the
394mouse is released." (KM)
395  (LET ((POINT (POINT))
396        (SHEET (WINDOW-SHEET *WINDOW*))
397        (START-LINE)
398        (END-LINE))
399    (COND ((WINDOW-MARK-P *WINDOW*)             ;If there is a region, use it
400           (REGION (BP1 BP2)
401                   (SETQ START-LINE (BP-LINE BP1)
402                         END-LINE (BP-LINE BP2))
403                   (OR (ZEROP (BP-INDEX BP2))
404                       (SETQ END-LINE (LINE-NEXT END-LINE)))))
405          (T
406           (SETQ START-LINE (BP-LINE POINT)
407                 END-LINE (LINE-NEXT START-LINE))))
408    (MULTIPLE-VALUE-BIND (X Y)
409        (FIND-BP-IN-WINDOW-COORDS (FORWARD-OVER *BLANKS* (BEG-OF-LINE START-LINE)) *WINDOW*)
410      (FUNCALL SHEET ':SET-MOUSE-POSITION X Y))
411    (PROCESS-WAIT "MOUSE" #'(LAMBDA () (OR (ZEROP TV:MOUSE-LAST-BUTTONS) *MOUSE-P*)))
412    (DO ((LAST-X TV:MOUSE-X TV:MOUSE-X)
413         (LAST-Y TV:MOUSE-Y TV:MOUSE-Y)
414         (LM (TV:SHEET-INSIDE-LEFT SHEET))
415         (BP (COPY-BP POINT))
416         (DELTA))
417        (NIL)
418      (SETQ DELTA (LINE-INDENTATION START-LINE SHEET))
419      (MOVE-BP BP START-LINE 0)
420      (INDENT-LINE BP (MAX 0 (- TV:MOUSE-X LM)) SHEET)
421      (SETQ DELTA (- (LINE-INDENTATION START-LINE SHEET) DELTA))
422      (OR (= DELTA 0)
423          (DO ((LINE START-LINE (LINE-NEXT LINE)))
424              ((EQ LINE END-LINE))
425            (AND (NEQ LINE START-LINE)
426                 (INDENT-LINE (MOVE-BP BP LINE 0)
427                              (MAX 0 (+ DELTA (LINE-INDENTATION LINE SHEET))) SHEET))))
428      (MUST-REDISPLAY *WINDOW* DIS-TEXT)
429      (REDISPLAY *WINDOW* ':POINT)
430      (OR (WAIT-FOR-MOUSE LAST-X LAST-Y 5) (RETURN NIL))))
431  DIS-TEXT)
432
433;;; *** This should figure out some other kind of mouse-blinker ***
434(DEFCOM COM-MOUSE-INDENT-UNDER "Indent the current line as selected by the mouse." (KM)
435  (LET ((CH (FUNCALL STANDARD-INPUT ':MOUSE-OR-KBD-TYI)))
436    (COND ((= CH #\MOUSE-1-1)
437           (INDENT-LINE (POINT) (BP-INDENTATION (MOUSE-BP *WINDOW*)))
438           DIS-TEXT)
439          (T
440           (FUNCALL STANDARD-INPUT ':UNTYI CH)
441           (COM-INDENT-UNDER)))))
Note: See TracBrowser for help on using the browser.