/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (hide annotations)
Thu Jan 6 16:41:11 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.47: +18 -3 lines
Improved next- and previous-line commands so that a sequence
of such commands tries to preserve the original column.
1 ejohnson 1.27 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
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     ;;; GUI for the Climacs editor.
24    
25     (in-package :climacs-gui)
26    
27     (defclass filename-mixin ()
28     ((filename :initform nil :accessor filename)))
29    
30 rstrandh 1.38 (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin)
31     ((needs-saving :initform nil :accessor needs-saving))
32     (:default-initargs :name "*scratch*"))
33    
34 ejohnson 1.27
35     (defclass climacs-pane (application-pane)
36     ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
37     (point :initform nil :initarg :point :reader point)
38     (syntax :initarg :syntax :accessor syntax)
39     (mark :initform nil :initarg :mark :reader mark)))
40    
41     (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
42     (declare (ignore args))
43     (with-slots (buffer point syntax mark) pane
44     (when (null point)
45     (setf point (make-instance 'standard-right-sticky-mark
46     :buffer buffer)))
47     (when (null mark)
48     (setf mark (make-instance 'standard-right-sticky-mark
49     :buffer buffer)))
50     (setf syntax (make-instance 'texinfo-syntax :pane pane))))
51    
52 rstrandh 1.28 (defclass minibuffer-pane (application-pane) ())
53    
54     (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
55     (declare (ignore type args))
56     (window-clear pane))
57    
58 ejohnson 1.27 (define-application-frame climacs ()
59     ((win :reader win))
60     (:panes
61     (win (make-pane 'climacs-pane
62     :width 900 :height 400
63     :name 'win
64     :incremental-redisplay t
65     :display-function 'display-win))
66     (info :application
67 rstrandh 1.28 :width 900 :height 20 :max-height 20
68     :name 'info :background +light-gray+
69     :scroll-bars nil
70     :incremental-redisplay t
71     :display-function 'display-info)
72     (int (make-pane 'minibuffer-pane
73     :width 900 :height 20 :max-height 20 :min-height 20
74     :scroll-bars nil)))
75 ejohnson 1.27 (:layouts
76     (default
77     (vertically (:scroll-bars nil)
78     (scrolling (:width 900 :height 400) win)
79     info
80 rstrandh 1.45 int))
81     (without-interactor
82     (vertically (:scroll-bars nil)
83     (scrolling (:width 900 :height 400) win)
84     info)))
85 ejohnson 1.27 (:top-level (climacs-top-level)))
86    
87 rstrandh 1.28 (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
88     (declare (ignore args))
89     (clear-modify (buffer (win frame))))
90    
91 ejohnson 1.27 (defun climacs ()
92     "Starts up a climacs session"
93     (let ((frame (make-application-frame 'climacs)))
94     (run-frame-top-level frame)))
95    
96 rstrandh 1.30 (defun display-message (format-string &rest format-args)
97     (apply #'format *standard-input* format-string format-args))
98    
99 ejohnson 1.27 (defun display-info (frame pane)
100     (let* ((win (win frame))
101     (buf (buffer win))
102 rstrandh 1.38 (name-info (format nil " ~a ~a Syntax: ~a"
103 rstrandh 1.28 (if (needs-saving buf) "**" "--")
104 rstrandh 1.38 (name buf)
105     (name (syntax win)))))
106 ejohnson 1.27 (princ name-info pane)))
107    
108     (defun display-win (frame pane)
109     "The display function used by the climacs application frame."
110     (declare (ignore frame))
111     (redisplay-pane pane))
112    
113     (defun find-gestures (gestures start-table)
114     (loop with table = (find-command-table start-table)
115     for (gesture . rest) on gestures
116     for item = (find-keystroke-item gesture table :errorp nil)
117     while item
118     do (if (eq (command-menu-item-type item) :command)
119     (return (if (null rest) item nil))
120     (setf table (command-menu-item-value item)))
121     finally (return item)))
122    
123     (defvar *kill-ring* (initialize-kill-ring 7))
124     (defparameter *current-gesture* nil)
125    
126 rstrandh 1.36 (defun meta-digit (gesture)
127     (position gesture
128     '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
129     (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
130     :test #'event-matches-gesture-name-p))
131    
132 rstrandh 1.47 (defun climacs-read-gesture ()
133     (loop for gesture = (read-gesture :stream *standard-input*)
134     when (event-matches-gesture-name-p gesture '(#\g :control))
135     do (throw 'outer-loop nil)
136     until (or (characterp gesture)
137     (and (typep gesture 'keyboard-event)
138     (or (keyboard-event-character gesture)
139     (not (member (keyboard-event-key-name
140     gesture)
141     '(:control-left :control-right
142     :shift-left :shift-right
143     :meta-left :meta-right
144     :super-left :super-right
145     :hyper-left :hyper-right
146     :shift-lock :caps-lock
147     :alt-left :alt-right))))))
148     finally (return gesture)))
149    
150 rstrandh 1.36 (defun read-numeric-argument (&key (stream *standard-input*))
151 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
152 rstrandh 1.36 (cond ((event-matches-gesture-name-p gesture '(#\u :control))
153     (let ((numarg 4))
154 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
155 rstrandh 1.36 while (event-matches-gesture-name-p gesture '(#\u :control))
156     do (setf numarg (* 4 numarg))
157     finally (unread-gesture gesture :stream stream))
158 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
159 rstrandh 1.36 (cond ((and (characterp gesture)
160     (digit-char-p gesture 10))
161     (setf numarg (- (char-code gesture) (char-code #\0)))
162 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
163 rstrandh 1.36 while (and (characterp gesture)
164     (digit-char-p gesture 10))
165     do (setf gesture (+ (* 10 numarg)
166     (- (char-code gesture) (char-code #\0))))
167     finally (unread-gesture gesture :stream stream)
168     (return (values numarg t))))
169     (t
170     (values numarg t))))))
171     ((meta-digit gesture)
172     (let ((numarg (meta-digit gesture)))
173 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
174 rstrandh 1.36 while (meta-digit gesture)
175     do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
176     finally (unread-gesture gesture :stream stream)
177     (return (values numarg t)))))
178     (t (unread-gesture gesture :stream stream)
179     (values 1 nil)))))
180    
181 rstrandh 1.48 (defvar *previous-command*)
182    
183 ejohnson 1.27 (defun climacs-top-level (frame &key
184     command-parser command-unparser
185     partial-command-parser prompt)
186     (declare (ignore command-parser command-unparser partial-command-parser prompt))
187     (setf (slot-value frame 'win) (find-pane-named frame 'win))
188     (let ((*standard-output* (find-pane-named frame 'win))
189     (*standard-input* (find-pane-named frame 'int))
190     (*print-pretty* nil)
191     (*abort-gestures* nil))
192     (redisplay-frame-panes frame :force-p t)
193 rstrandh 1.47 (loop (catch 'outer-loop
194     (loop with gestures = '()
195     with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*)
196     do (setf *current-gesture* (climacs-read-gesture))
197     (setf gestures (nconc gestures (list *current-gesture*)))
198     (let ((item (find-gestures gestures 'global-climacs-table)))
199     (cond ((not item)
200     (beep) (setf gestures '()))
201     ((eq (command-menu-item-type item) :command)
202     (let ((command (command-menu-item-value item)))
203     (unless (consp command)
204     (setf command (list command)))
205     (setf command (substitute-numeric-argument-marker command numarg))
206     (handler-case
207     (execute-frame-command frame command)
208     (error (condition)
209     (beep)
210     (format *error-output* "~a~%" condition)))
211 rstrandh 1.48 (setf gestures '())
212     (setf *previous-command* (if (consp command)
213     (car command)
214     command))))
215 rstrandh 1.47 (t nil)))
216     (let ((buffer (buffer (win frame))))
217     (when (modified-p buffer)
218     (setf (needs-saving buffer) t)))
219     (redisplay-frame-panes frame)))
220     (beep)
221     (let ((buffer (buffer (win frame))))
222     (when (modified-p buffer)
223     (setf (needs-saving buffer) t)))
224     (redisplay-frame-panes frame))))
225 ejohnson 1.27
226 abridgewater 1.34 (defmacro define-named-command (command-name args &body body)
227     `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body))
228    
229     (define-named-command (com-quit) ()
230 ejohnson 1.27 (frame-exit *application-frame*))
231    
232     (define-command com-self-insert ()
233     (unless (constituentp *current-gesture*)
234     (possibly-expand-abbrev (point (win *application-frame*))))
235 rstrandh 1.28 (insert-object (point (win *application-frame*)) *current-gesture*))
236 ejohnson 1.27
237 abridgewater 1.34 (define-named-command com-beginning-of-line ()
238 ejohnson 1.27 (beginning-of-line (point (win *application-frame*))))
239    
240 abridgewater 1.34 (define-named-command com-end-of-line ()
241 ejohnson 1.27 (end-of-line (point (win *application-frame*))))
242    
243 abridgewater 1.34 (define-named-command com-delete-object ()
244 rstrandh 1.28 (delete-range (point (win *application-frame*))))
245 ejohnson 1.27
246 abridgewater 1.34 (define-named-command com-backward-delete-object ()
247 rstrandh 1.28 (delete-range (point (win *application-frame*)) -1))
248 ejohnson 1.27
249 rstrandh 1.42 (define-named-command com-transpose-objects ()
250     (let* ((point (point (win *application-frame*))))
251     (unless (beginning-of-buffer-p point)
252     (when (end-of-line-p point)
253 rstrandh 1.43 (backward-object point))
254     (let ((object (object-after point)))
255     (delete-range point)
256     (backward-object point)
257     (insert-object point object)
258     (forward-object point)))))
259    
260     (defgeneric backward-object (mark &optional count))
261     (defmethod backward-object ((mark climacs-buffer::mark-mixin)
262     &optional (count 1))
263     (decf (offset mark) count))
264    
265     (defgeneric forward-object (mark &optional count))
266     (defmethod forward-object ((mark climacs-buffer::mark-mixin)
267     &optional (count 1))
268     (incf (offset mark) count))
269    
270     (define-named-command com-backward-object ()
271     (backward-object (point (win *application-frame*))))
272    
273     (define-named-command com-forward-object ()
274     (forward-object (point (win *application-frame*))))
275    
276     (define-named-command com-transpose-words ()
277     (let* ((point (point (win *application-frame*))))
278     (let (bw1 bw2 ew1 ew2)
279     (backward-word point)
280     (setf bw1 (offset point))
281     (forward-word point)
282     (setf ew1 (offset point))
283     (forward-word point)
284     (when (= (offset point) ew1)
285     ;; this is emacs' message in the minibuffer
286     (error "Don't have two things to transpose"))
287     (setf ew2 (offset point))
288     (backward-word point)
289     (setf bw2 (offset point))
290     (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
291     (w1 (buffer-sequence (buffer point) bw1 ew1)))
292     (delete-word point)
293     (insert-sequence point w1)
294     (backward-word point)
295     (backward-word point)
296     (delete-word point)
297     (insert-sequence point w2)
298     (forward-word point)))))
299 rstrandh 1.42
300 rstrandh 1.45 (define-named-command com-transpose-lines ()
301     (let ((point (point (win *application-frame*))))
302     (beginning-of-line point)
303     (unless (beginning-of-buffer-p point)
304     (previous-line point))
305     (let* ((bol (offset point))
306     (eol (progn (end-of-line point)
307     (offset point)))
308     (line (buffer-sequence (buffer point) bol eol)))
309     (delete-region bol point)
310     ;; Remove newline at end of line as well.
311     (unless (end-of-buffer-p point)
312     (delete-range point))
313     ;; If the current line is at the end of the buffer, we want to
314     ;; be able to insert past it, so we need to get an extra line
315     ;; at the end.
316     (when (progn (end-of-line point)
317     (end-of-buffer-p point))
318     (insert-object point #\Newline))
319     (next-line point)
320     (insert-sequence point line)
321     (insert-object point #\Newline))))
322    
323 rstrandh 1.48 (defvar *goal-column*)
324    
325 abridgewater 1.34 (define-named-command com-previous-line ()
326 rstrandh 1.48 (let ((point (point (win *application-frame*))))
327     (unless (or (eq *previous-command* 'com-previous-line)
328     (eq *previous-command* 'com-next-line))
329     (setf *goal-column* (column-number point)))
330     (previous-line point *goal-column*)))
331 ejohnson 1.27
332 abridgewater 1.34 (define-named-command com-next-line ()
333 rstrandh 1.48 (let ((point (point (win *application-frame*))))
334     (unless (or (eq *previous-command* 'com-previous-line)
335     (eq *previous-command* 'com-next-line))
336     (setf *goal-column* (column-number point)))
337     (next-line point *goal-column*)))
338 ejohnson 1.27
339 abridgewater 1.34 (define-named-command com-open-line ()
340 rstrandh 1.28 (open-line (point (win *application-frame*))))
341 ejohnson 1.27
342 abridgewater 1.34 (define-named-command com-kill-line ()
343 rstrandh 1.28 (kill-line (point (win *application-frame*))))
344 ejohnson 1.27
345 abridgewater 1.34 (define-named-command com-forward-word ()
346 ejohnson 1.27 (forward-word (point (win *application-frame*))))
347    
348 abridgewater 1.34 (define-named-command com-backward-word ()
349 ejohnson 1.27 (backward-word (point (win *application-frame*))))
350    
351 abridgewater 1.34 (define-named-command com-delete-word ()
352 rstrandh 1.32 (delete-word (point (win *application-frame*))))
353    
354 abridgewater 1.34 (define-named-command com-backward-delete-word ()
355 rstrandh 1.32 (backward-delete-word (point (win *application-frame*))))
356    
357 abridgewater 1.34 (define-named-command com-toggle-layout ()
358 ejohnson 1.27 (setf (frame-current-layout *application-frame*)
359     (if (eq (frame-current-layout *application-frame*) 'default)
360 rstrandh 1.45 'without-interactor
361 ejohnson 1.27 'default)))
362    
363     (define-command com-extended-command ()
364     (let ((item (accept 'command :prompt "Extended Command")))
365     (execute-frame-command *application-frame* item)))
366    
367 rstrandh 1.41 (eval-when (:compile-toplevel :load-toplevel)
368 ejohnson 1.35 (define-presentation-type completable-pathname ()
369     :inherit-from 'pathname))
370 ejohnson 1.27
371     (defun filename-completer (so-far mode)
372     (flet ((remove-trail (s)
373     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
374     (if pos (1+ pos) 0)))))
375     (let* ((directory-prefix
376     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
377     ""
378     (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
379     (full-so-far (concatenate 'string directory-prefix so-far))
380     (pathnames
381     (loop with length = (length full-so-far)
382     for path in (directory (concatenate 'string
383     (remove-trail so-far)
384     "*.*"))
385     when (let ((mismatch (mismatch (namestring path) full-so-far)))
386     (or (null mismatch) (= mismatch length)))
387     collect path))
388     (strings (mapcar #'namestring pathnames))
389     (first-string (car strings))
390     (length-common-prefix nil)
391     (completed-string nil)
392     (full-completed-string nil))
393     (unless (null pathnames)
394     (setf length-common-prefix
395     (loop with length = (length first-string)
396     for string in (cdr strings)
397     do (setf length (min length (or (mismatch string first-string) length)))
398     finally (return length))))
399     (unless (null pathnames)
400     (setf completed-string
401     (subseq first-string (length directory-prefix)
402     (if (null (cdr pathnames)) nil length-common-prefix)))
403     (setf full-completed-string
404     (concatenate 'string directory-prefix completed-string)))
405     (case mode
406     ((:complete-limited :complete-maximal)
407     (cond ((null pathnames)
408     (values so-far nil nil 0 nil))
409     ((null (cdr pathnames))
410     (values completed-string t (car pathnames) 1 nil))
411     (t
412     (values completed-string nil nil (length pathnames) nil))))
413     (:complete
414     (cond ((null pathnames)
415     (values so-far t so-far 1 nil))
416     ((null (cdr pathnames))
417     (values completed-string t (car pathnames) 1 nil))
418     ((find full-completed-string strings :test #'string-equal)
419     (let ((pos (position full-completed-string strings :test #'string-equal)))
420     (values completed-string
421     t (elt pathnames pos) (length pathnames) nil)))
422     (t
423     (values completed-string nil nil (length pathnames) nil))))
424     (:possibilities
425     (values nil nil nil (length pathnames)
426     (loop with length = (length directory-prefix)
427     for name in pathnames
428     collect (list (subseq (namestring name) length nil)
429     name))))))))
430    
431     (define-presentation-method accept
432     ((type completable-pathname) stream (view textual-view) &key)
433     (multiple-value-bind (pathname success string)
434     (complete-input stream
435     #'filename-completer
436     :partial-completers '(#\Space)
437     :allow-any-input t)
438     (declare (ignore success))
439     (or pathname string)))
440    
441     (defun pathname-filename (pathname)
442     (if (null (pathname-type pathname))
443     (pathname-name pathname)
444     (concatenate 'string (pathname-name pathname)
445     "." (pathname-type pathname))))
446    
447 abridgewater 1.34 (define-named-command com-find-file ()
448 ejohnson 1.27 (let ((filename (accept 'completable-pathname
449     :prompt "Find File")))
450     (with-slots (buffer point syntax) (win *application-frame*)
451     (setf buffer (make-instance 'climacs-buffer)
452     point (make-instance 'standard-right-sticky-mark :buffer buffer)
453     syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)))
454     (with-open-file (stream filename :direction :input :if-does-not-exist :create)
455     (input-from-stream stream buffer 0))
456     (setf (filename buffer) filename
457 rstrandh 1.28 (name buffer) (pathname-filename filename)
458     (needs-saving buffer) nil)
459 rstrandh 1.37 (beginning-of-buffer point)
460 rstrandh 1.28 ;; this one is needed so that the buffer modification protocol
461     ;; resets the low and high marks after redisplay
462 rstrandh 1.37 (redisplay-frame-panes *application-frame*))))
463 ejohnson 1.27
464 abridgewater 1.34 (define-named-command com-save-buffer ()
465 rstrandh 1.30 (let* ((buffer (buffer (win *application-frame*)))
466     (filename (or (filename buffer)
467     (accept 'completable-pathname
468     :prompt "Save Buffer to File"))))
469     (if (or (null (filename buffer))
470     (needs-saving buffer))
471     (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
472     (output-to-stream stream buffer 0 (size buffer)))
473     (setf (filename buffer) filename
474     (name buffer) (pathname-filename filename))
475     (display-message "Wrote: ~a" (filename buffer)))
476     (display-message "No changes need to be saved from ~a" (name buffer)))
477     (setf (needs-saving buffer) nil)))
478 ejohnson 1.27
479 abridgewater 1.34 (define-named-command com-write-buffer ()
480 ejohnson 1.27 (let ((filename (accept 'completable-pathname
481     :prompt "Write Buffer to File"))
482     (buffer (buffer (win *application-frame*))))
483     (with-open-file (stream filename :direction :output :if-exists :supersede)
484     (output-to-stream stream buffer 0 (size buffer)))
485     (setf (filename buffer) filename
486 rstrandh 1.28 (name buffer) (pathname-filename filename)
487 rstrandh 1.30 (needs-saving buffer) nil)
488     (display-message "Wrote: ~a" (filename buffer))))
489 ejohnson 1.27
490 abridgewater 1.34 (define-named-command com-beginning-of-buffer ()
491 ejohnson 1.27 (beginning-of-buffer (point (win *application-frame*))))
492    
493 rstrandh 1.39 (define-named-command com-page-down ()
494     (let ((pane (win *application-frame*)))
495     (page-down pane (syntax pane))))
496    
497 rstrandh 1.40 (define-named-command com-page-up ()
498     (let ((pane (win *application-frame*)))
499     (page-up pane (syntax pane))))
500    
501 abridgewater 1.34 (define-named-command com-end-of-buffer ()
502 ejohnson 1.27 (end-of-buffer (point (win *application-frame*))))
503    
504 abridgewater 1.34 (define-named-command com-back-to-indentation ()
505 rstrandh 1.32 (let ((point (point (win *application-frame*))))
506     (beginning-of-line point)
507     (loop until (end-of-line-p point)
508     while (whitespacep (object-after point))
509     do (incf (offset point)))))
510    
511 abridgewater 1.34 (define-named-command com-goto-position ()
512 rstrandh 1.32 (setf (offset (point (win *application-frame*)))
513     (accept 'integer :prompt "Goto Position")))
514    
515 abridgewater 1.34 (define-named-command com-goto-line ()
516 rstrandh 1.32 (loop with mark = (make-instance 'standard-right-sticky-mark
517     :buffer (buffer (win *application-frame*)))
518     do (end-of-line mark)
519     until (end-of-buffer-p mark)
520     repeat (accept 'integer :prompt "Goto Line")
521     do (incf (offset mark))
522     (end-of-line mark)
523     finally (beginning-of-line mark)
524     (setf (offset (point (win *application-frame*)))
525     (offset mark))))
526    
527 abridgewater 1.34 (define-named-command com-browse-url ()
528 ejohnson 1.27 (accept 'url :prompt "Browse URL"))
529    
530 abridgewater 1.34 (define-named-command com-set-mark ()
531 ejohnson 1.27 (with-slots (point mark) (win *application-frame*)
532 rstrandh 1.45 (setf mark (clone-mark point))))
533    
534     (define-named-command com-exchange-point-and-mark ()
535     (with-slots (point mark) (win *application-frame*)
536     (psetf (offset mark) (offset point)
537     (offset point) (offset mark))))
538 rstrandh 1.38
539     (define-named-command com-set-syntax ()
540     (setf (syntax (win *application-frame*))
541     (make-instance (accept 'syntax :prompt "Set Syntax")
542     :pane (win *application-frame*))))
543 ejohnson 1.27
544     ;;;;;;;;;;;;;;;;;;;;
545     ;; Kill ring commands
546    
547 ejohnson 1.31 ;; Copies an element from a kill-ring to a buffer at the given offset
548 abridgewater 1.34 (define-named-command com-copy-in ()
549 ejohnson 1.31 (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*)))
550 ejohnson 1.27
551 ejohnson 1.31 ;; Cuts an element from a kill-ring out to a buffer at a given offset
552 abridgewater 1.34 (define-named-command com-cut-in ()
553 ejohnson 1.31 (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*)))
554 ejohnson 1.27
555 ejohnson 1.31 ;; Destructively cut a given buffer region into the kill-ring
556 abridgewater 1.34 (define-named-command com-cut-out ()
557 ejohnson 1.27 (with-slots (buffer point mark)(win *application-frame*)
558 ejohnson 1.31 (if (< (offset point) (offset mark))
559     ((lambda (b o1 o2)
560     (kr-push *kill-ring* (buffer-sequence b o1 o2))
561     (delete-buffer-range b o1 (- o2 o1)))
562     buffer (offset point) (offset mark))
563     ((lambda (b o1 o2)
564     (kr-push *kill-ring* (buffer-sequence b o2 o1))
565     (delete-buffer-range b o1 (- o2 o1)))
566     buffer (offset mark) (offset point)))))
567    
568 ejohnson 1.27
569 ejohnson 1.31 ;; Non destructively copies in buffer region to the kill ring
570 abridgewater 1.34 (define-named-command com-copy-out ()
571 ejohnson 1.27 (with-slots (buffer point mark)(win *application-frame*)
572     (let ((off1 (offset point))
573     (off2 (offset mark)))
574     (if (< off1 off2)
575 ejohnson 1.31 (kr-push *kill-ring* (buffer-sequence buffer off1 off2))
576     (kr-push *kill-ring* (buffer-sequence buffer off2 off1))))))
577 ejohnson 1.27
578     ;; Needs adjustment to be like emacs M-y
579 abridgewater 1.34 (define-named-command com-kr-rotate ()
580 ejohnson 1.27 (kr-rotate *kill-ring* -1))
581    
582     ;; Not bound to a key yet
583 abridgewater 1.34 (define-named-command com-kr-resize ()
584 ejohnson 1.46 (let ((size (accept 'integer :prompt "New kill ring size")))
585 ejohnson 1.27 (kr-resize *kill-ring* size)))
586 rstrandh 1.47
587     (define-named-command com-search-forward ()
588     (search-forward (point (win *application-frame*))
589     (accept 'string :prompt "Search Forward")
590     :test (lambda (a b)
591     (and (characterp b) (char-equal a b)))))
592    
593     (define-named-command com-search-backward ()
594     (search-backward (point (win *application-frame*))
595     (accept 'string :prompt "Search Backward")
596     :test (lambda (a b)
597     (and (characterp b) (char-equal a b)))))
598 ejohnson 1.27
599     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
600     ;;;
601     ;;; Global command table
602    
603     (make-command-table 'global-climacs-table :errorp nil)
604    
605     (defun global-set-key (gesture command)
606     (add-command-to-command-table command 'global-climacs-table
607     :keystroke gesture :errorp nil))
608    
609     (loop for code from (char-code #\space) to (char-code #\~)
610     do (global-set-key (code-char code) 'com-self-insert))
611    
612     (global-set-key #\newline 'com-self-insert)
613     (global-set-key #\tab 'com-self-insert)
614     (global-set-key '(#\f :control) 'com-forward-object)
615     (global-set-key '(#\b :control) 'com-backward-object)
616     (global-set-key '(#\a :control) 'com-beginning-of-line)
617     (global-set-key '(#\e :control) 'com-end-of-line)
618     (global-set-key '(#\d :control) 'com-delete-object)
619     (global-set-key '(#\p :control) 'com-previous-line)
620     (global-set-key '(#\n :control) 'com-next-line)
621     (global-set-key '(#\o :control) 'com-open-line)
622     (global-set-key '(#\k :control) 'com-kill-line)
623 rstrandh 1.42 (global-set-key '(#\t :control) 'com-transpose-objects)
624 ejohnson 1.27 (global-set-key '(#\Space :control) 'com-set-mark)
625     (global-set-key '(#\y :control) 'com-copy-in)
626     (global-set-key '(#\w :control) 'com-cut-out)
627     (global-set-key '(#\f :meta) 'com-forward-word)
628     (global-set-key '(#\b :meta) 'com-backward-word)
629 rstrandh 1.43 (global-set-key '(#\t :meta) 'com-transpose-words)
630 ejohnson 1.27 (global-set-key '(#\x :meta) 'com-extended-command)
631     (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only
632     (global-set-key '(#\w :meta) 'com-copy-out)
633 rstrandh 1.39 (global-set-key '(#\v :control) 'com-page-down)
634 rstrandh 1.40 (global-set-key '(#\v :meta) 'com-page-up)
635 ejohnson 1.27 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
636     (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
637     (global-set-key '(#\u :meta) 'com-browse-url)
638 rstrandh 1.32 (global-set-key '(#\m :meta) 'com-back-to-indentation)
639     (global-set-key '(#\d :meta) 'com-delete-word)
640     (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
641 ejohnson 1.27
642     (global-set-key '(:up) 'com-previous-line)
643     (global-set-key '(:down) 'com-next-line)
644     (global-set-key '(:left) 'com-backward-object)
645     (global-set-key '(:right) 'com-forward-object)
646     (global-set-key '(:left :control) 'com-backward-word)
647     (global-set-key '(:right :control) 'com-forward-word)
648     (global-set-key '(:home) 'com-beginning-of-line)
649     (global-set-key '(:end) 'com-end-of-line)
650     (global-set-key '(:home :control) 'com-beginning-of-buffer)
651     (global-set-key '(:end :control) 'com-end-of-buffer)
652     (global-set-key #\Rubout 'com-delete-object)
653     (global-set-key #\Backspace 'com-backward-delete-object)
654    
655     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
656     ;;;
657     ;;; C-x command table
658    
659     (make-command-table 'c-x-climacs-table :errorp nil)
660    
661     (add-menu-item-to-command-table 'global-climacs-table "C-x"
662     :menu 'c-x-climacs-table
663     :keystroke '(#\x :control))
664    
665     (defun c-x-set-key (gesture command)
666     (add-command-to-command-table command 'c-x-climacs-table
667     :keystroke gesture :errorp nil))
668    
669     (c-x-set-key '(#\c :control) 'com-quit)
670     (c-x-set-key '(#\f :control) 'com-find-file)
671     (c-x-set-key '(#\s :control) 'com-save-buffer)
672 rstrandh 1.45 (c-x-set-key '(#\t :control) 'com-transpose-lines)
673 ejohnson 1.27 (c-x-set-key '(#\w :control) 'com-write-buffer)
674 rstrandh 1.45 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
675 rstrandh 1.44
676     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
677     ;;;
678     ;;; Some Unicode stuff
679    
680     (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
681     (insert-object (point (win *application-frame*)) (code-char code)))
682    
683     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
684     ;;;
685     ;;; Dead-acute command table
686    
687     (make-command-table 'dead-acute-climacs-table :errorp nil)
688    
689     (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
690     :menu 'dead-acute-climacs-table
691     :keystroke '(:dead--acute))
692    
693     (defun dead-acute-set-key (gesture command)
694     (add-command-to-command-table command 'dead-acute-climacs-table
695     :keystroke gesture :errorp nil))
696    
697     (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
698     (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
699     (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
700     (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
701     (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
702     (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
703     (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
704     (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
705     (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
706     (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
707     (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
708     (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
709     (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
710     (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
711     (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
712     (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
713     (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
714     (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
715     (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
716     (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
717    
718 rstrandh 1.45 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
719    
720     (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
721     :menu 'dead-acute-dead-accute-climacs-table
722     :keystroke '(:dead--acute))
723    
724     (defun dead-acute-dead-accute-set-key (gesture command)
725     (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
726     :keystroke gesture :errorp nil))
727    
728     (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
729     (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
730 rstrandh 1.44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
731     ;;;
732     ;;; Dead-grave command table
733    
734     (make-command-table 'dead-grave-climacs-table :errorp nil)
735    
736     (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
737     :menu 'dead-grave-climacs-table
738     :keystroke '(:dead--grave))
739    
740     (defun dead-grave-set-key (gesture command)
741     (add-command-to-command-table command 'dead-grave-climacs-table
742     :keystroke gesture :errorp nil))
743    
744     (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
745     (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
746     (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
747     (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
748     (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
749     (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
750     (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
751     (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
752     (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
753     (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
754     (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
755    
756     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
757     ;;;
758     ;;; Dead-diaeresis command table
759    
760     (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
761    
762     (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
763     :menu 'dead-diaeresis-climacs-table
764     :keystroke '(:dead--diaeresis :shift))
765    
766     (defun dead-diaeresis-set-key (gesture command)
767     (add-command-to-command-table command 'dead-diaeresis-climacs-table
768     :keystroke gesture :errorp nil))
769    
770     (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
771     (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
772     (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
773     (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
774     (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
775     (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
776     (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
777     (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
778     (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
779     (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
780     (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
781     (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
782    
783     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
784     ;;;
785     ;;; Dead-tilde command table
786    
787     (make-command-table 'dead-tilde-climacs-table :errorp nil)
788    
789     (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
790     :menu 'dead-tilde-climacs-table
791     :keystroke '(:dead--tilde :shift))
792    
793     (defun dead-tilde-set-key (gesture command)
794     (add-command-to-command-table command 'dead-tilde-climacs-table
795     :keystroke gesture :errorp nil))
796    
797     (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
798     (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
799     (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
800     (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
801     (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
802     (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
803     (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
804     (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
805     (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
806     (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
807     (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
808    
809     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
810     ;;;
811     ;;; Dead-circumflex command table
812    
813     (make-command-table 'dead-circumflex-climacs-table :errorp nil)
814    
815     (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
816     :menu 'dead-circumflex-climacs-table
817     :keystroke '(:dead--circumflex :shift))
818    
819     (defun dead-circumflex-set-key (gesture command)
820     (add-command-to-command-table command 'dead-circumflex-climacs-table
821     :keystroke gesture :errorp nil))
822    
823     (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
824     (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
825     (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
826     (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
827     (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
828     (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
829     (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
830     (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
831     (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
832     (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
833     (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

  ViewVC Help
Powered by ViewVC 1.1.5