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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (show 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 ;;; -*- 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 (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
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 (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 (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 :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 (:layouts
76 (default
77 (vertically (:scroll-bars nil)
78 (scrolling (:width 900 :height 400) win)
79 info
80 int))
81 (without-interactor
82 (vertically (:scroll-bars nil)
83 (scrolling (:width 900 :height 400) win)
84 info)))
85 (:top-level (climacs-top-level)))
86
87 (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
88 (declare (ignore args))
89 (clear-modify (buffer (win frame))))
90
91 (defun climacs ()
92 "Starts up a climacs session"
93 (let ((frame (make-application-frame 'climacs)))
94 (run-frame-top-level frame)))
95
96 (defun display-message (format-string &rest format-args)
97 (apply #'format *standard-input* format-string format-args))
98
99 (defun display-info (frame pane)
100 (let* ((win (win frame))
101 (buf (buffer win))
102 (name-info (format nil " ~a ~a Syntax: ~a"
103 (if (needs-saving buf) "**" "--")
104 (name buf)
105 (name (syntax win)))))
106 (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 (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 (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 (defun read-numeric-argument (&key (stream *standard-input*))
151 (let ((gesture (climacs-read-gesture)))
152 (cond ((event-matches-gesture-name-p gesture '(#\u :control))
153 (let ((numarg 4))
154 (loop for gesture = (climacs-read-gesture)
155 while (event-matches-gesture-name-p gesture '(#\u :control))
156 do (setf numarg (* 4 numarg))
157 finally (unread-gesture gesture :stream stream))
158 (let ((gesture (climacs-read-gesture)))
159 (cond ((and (characterp gesture)
160 (digit-char-p gesture 10))
161 (setf numarg (- (char-code gesture) (char-code #\0)))
162 (loop for gesture = (climacs-read-gesture)
163 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 (loop for gesture = (climacs-read-gesture)
174 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 (defvar *previous-command*)
182
183 (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 (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 (setf gestures '())
212 (setf *previous-command* (if (consp command)
213 (car command)
214 command))))
215 (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
226 (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 (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 (insert-object (point (win *application-frame*)) *current-gesture*))
236
237 (define-named-command com-beginning-of-line ()
238 (beginning-of-line (point (win *application-frame*))))
239
240 (define-named-command com-end-of-line ()
241 (end-of-line (point (win *application-frame*))))
242
243 (define-named-command com-delete-object ()
244 (delete-range (point (win *application-frame*))))
245
246 (define-named-command com-backward-delete-object ()
247 (delete-range (point (win *application-frame*)) -1))
248
249 (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 (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
300 (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 (defvar *goal-column*)
324
325 (define-named-command com-previous-line ()
326 (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
332 (define-named-command com-next-line ()
333 (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
339 (define-named-command com-open-line ()
340 (open-line (point (win *application-frame*))))
341
342 (define-named-command com-kill-line ()
343 (kill-line (point (win *application-frame*))))
344
345 (define-named-command com-forward-word ()
346 (forward-word (point (win *application-frame*))))
347
348 (define-named-command com-backward-word ()
349 (backward-word (point (win *application-frame*))))
350
351 (define-named-command com-delete-word ()
352 (delete-word (point (win *application-frame*))))
353
354 (define-named-command com-backward-delete-word ()
355 (backward-delete-word (point (win *application-frame*))))
356
357 (define-named-command com-toggle-layout ()
358 (setf (frame-current-layout *application-frame*)
359 (if (eq (frame-current-layout *application-frame*) 'default)
360 'without-interactor
361 '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 (eval-when (:compile-toplevel :load-toplevel)
368 (define-presentation-type completable-pathname ()
369 :inherit-from 'pathname))
370
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 (define-named-command com-find-file ()
448 (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 (name buffer) (pathname-filename filename)
458 (needs-saving buffer) nil)
459 (beginning-of-buffer point)
460 ;; this one is needed so that the buffer modification protocol
461 ;; resets the low and high marks after redisplay
462 (redisplay-frame-panes *application-frame*))))
463
464 (define-named-command com-save-buffer ()
465 (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
479 (define-named-command com-write-buffer ()
480 (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 (name buffer) (pathname-filename filename)
487 (needs-saving buffer) nil)
488 (display-message "Wrote: ~a" (filename buffer))))
489
490 (define-named-command com-beginning-of-buffer ()
491 (beginning-of-buffer (point (win *application-frame*))))
492
493 (define-named-command com-page-down ()
494 (let ((pane (win *application-frame*)))
495 (page-down pane (syntax pane))))
496
497 (define-named-command com-page-up ()
498 (let ((pane (win *application-frame*)))
499 (page-up pane (syntax pane))))
500
501 (define-named-command com-end-of-buffer ()
502 (end-of-buffer (point (win *application-frame*))))
503
504 (define-named-command com-back-to-indentation ()
505 (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 (define-named-command com-goto-position ()
512 (setf (offset (point (win *application-frame*)))
513 (accept 'integer :prompt "Goto Position")))
514
515 (define-named-command com-goto-line ()
516 (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 (define-named-command com-browse-url ()
528 (accept 'url :prompt "Browse URL"))
529
530 (define-named-command com-set-mark ()
531 (with-slots (point mark) (win *application-frame*)
532 (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
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
544 ;;;;;;;;;;;;;;;;;;;;
545 ;; Kill ring commands
546
547 ;; Copies an element from a kill-ring to a buffer at the given offset
548 (define-named-command com-copy-in ()
549 (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*)))
550
551 ;; Cuts an element from a kill-ring out to a buffer at a given offset
552 (define-named-command com-cut-in ()
553 (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*)))
554
555 ;; Destructively cut a given buffer region into the kill-ring
556 (define-named-command com-cut-out ()
557 (with-slots (buffer point mark)(win *application-frame*)
558 (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
569 ;; Non destructively copies in buffer region to the kill ring
570 (define-named-command com-copy-out ()
571 (with-slots (buffer point mark)(win *application-frame*)
572 (let ((off1 (offset point))
573 (off2 (offset mark)))
574 (if (< off1 off2)
575 (kr-push *kill-ring* (buffer-sequence buffer off1 off2))
576 (kr-push *kill-ring* (buffer-sequence buffer off2 off1))))))
577
578 ;; Needs adjustment to be like emacs M-y
579 (define-named-command com-kr-rotate ()
580 (kr-rotate *kill-ring* -1))
581
582 ;; Not bound to a key yet
583 (define-named-command com-kr-resize ()
584 (let ((size (accept 'integer :prompt "New kill ring size")))
585 (kr-resize *kill-ring* size)))
586
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
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 (global-set-key '(#\t :control) 'com-transpose-objects)
624 (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 (global-set-key '(#\t :meta) 'com-transpose-words)
630 (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 (global-set-key '(#\v :control) 'com-page-down)
634 (global-set-key '(#\v :meta) 'com-page-up)
635 (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 (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
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 (c-x-set-key '(#\t :control) 'com-transpose-lines)
673 (c-x-set-key '(#\w :control) 'com-write-buffer)
674 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
675
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 (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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