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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5