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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (hide annotations)
Fri Jan 7 07:26:24 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.48: +63 -18 lines
replaced *previous-command* and *goal-column* by slots in
the pane according to a suggestion by Rudi Schlatte.

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

  ViewVC Help
Powered by ViewVC 1.1.5