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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5