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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5