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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Sun Dec 26 07:18:01 2004 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.16: +3 -3 lines
Much improved redisplay algorithm.

The behavior when point is outside the current region on display is
much faster and similar to that of Emacs, in that the algorithm tries
to position point in the middle of the pane.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; GUI for the Climacs editor.
24
25 (in-package :climacs-gui)
26
27 (defclass filename-mixin ()
28 ((filename :initform nil :accessor filename)))
29
30 (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin) ())
31
32 (defclass climacs-pane (application-pane)
33 ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
34 (point :initform nil :initarg :point :reader point)
35 (syntax :initarg :syntax :accessor syntax)))
36
37 (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
38 (declare (ignore args))
39 (with-slots (buffer point syntax) pane
40 (when (null point)
41 (setf point (make-instance 'standard-right-sticky-mark
42 :buffer buffer)))
43 (setf syntax (make-instance 'texinfo-syntax :pane pane))))
44
45 (define-application-frame climacs ()
46 ((win :reader win))
47 (:panes
48 (win (make-pane 'climacs-pane
49 :width 900 :height 400
50 :name 'win
51 :display-function 'display-win))
52 (int :interactor :width 900 :height 50 :max-height 50))
53 (:layouts
54 (default
55 (vertically ()
56 (scrolling (:width 900 :height 400) win)
57 int)))
58 (:top-level (climacs-top-level)))
59
60 (defun climacs ()
61 "Starts up a climacs session"
62 (let ((frame (make-application-frame 'climacs)))
63 (run-frame-top-level frame)))
64
65 (defun display-win (frame pane)
66 "The display function used by the climacs application frame."
67 (declare (ignore frame))
68 (redisplay-pane pane))
69
70 (defun find-gestures (gestures start-table)
71 (loop with table = (find-command-table start-table)
72 for (gesture . rest) on gestures
73 for item = (find-keystroke-item gesture table :errorp nil)
74 while item
75 do (if (eq (command-menu-item-type item) :command)
76 (return (if (null rest) item nil))
77 (setf table (command-menu-item-value item)))
78 finally (return item)))
79
80 (defparameter *current-gesture* nil)
81
82 (defun climacs-top-level (frame &key
83 command-parser command-unparser
84 partial-command-parser prompt)
85 (declare (ignore command-parser command-unparser partial-command-parser prompt))
86 (setf (slot-value frame 'win) (find-pane-named frame 'win))
87 (let ((*standard-output* (frame-standard-output frame))
88 (*standard-input* (frame-standard-input frame))
89 (*print-pretty* nil))
90 (redisplay-frame-panes frame :force-p t)
91 (loop with gestures = '()
92 do (setf *current-gesture* (read-gesture :stream *standard-input*))
93 (when (or (characterp *current-gesture*)
94 (and (typep *current-gesture* 'keyboard-event)
95 (keyboard-event-character *current-gesture*)))
96 (setf gestures (nconc gestures (list *current-gesture*)))
97 (let ((item (find-gestures gestures 'global-climacs-table)))
98 (cond ((not item)
99 (beep) (setf gestures '()))
100 ((eq (command-menu-item-type item) :command)
101 (handler-case
102 (funcall (command-menu-item-value item))
103 (error (condition)
104 (beep)
105 (format *error-output* "~a~%" condition)))
106 (setf gestures '()))
107 (t nil))))
108 (redisplay-frame-panes frame :force-p t))))
109
110 (define-command com-quit ()
111 (frame-exit *application-frame*))
112
113 (define-command com-self-insert ()
114 (unless (constituentp *current-gesture*)
115 (possibly-expand-abbrev (point (win *application-frame*))))
116 (insert-object (point (win *application-frame*)) *current-gesture*))
117
118 (define-command com-backward-object ()
119 (decf (offset (point (win *application-frame*)))))
120
121 (define-command com-forward-object ()
122 (incf (offset (point (win *application-frame*)))))
123
124 (define-command com-beginning-of-line ()
125 (beginning-of-line (point (win *application-frame*))))
126
127 (define-command com-end-of-line ()
128 (end-of-line (point (win *application-frame*))))
129
130 (define-command com-delete-object ()
131 (delete-range (point (win *application-frame*))))
132
133 (define-command com-previous-line ()
134 (previous-line (point (win *application-frame*))))
135
136 (define-command com-next-line ()
137 (next-line (point (win *application-frame*))))
138
139 (define-command com-open-line ()
140 (open-line (point (win *application-frame*))))
141
142 (define-command com-kill-line ()
143 (kill-line (point (win *application-frame*))))
144
145 (define-command com-forward-word ()
146 (forward-word (point (win *application-frame*))))
147
148 (define-command com-backward-word ()
149 (backward-word (point (win *application-frame*))))
150
151 (define-command com-toggle-layout ()
152 (setf (frame-current-layout *application-frame*)
153 (if (eq (frame-current-layout *application-frame*) 'default)
154 'with-interactor
155 'default)))
156
157 (define-command com-extended-command ()
158 (accept 'command :prompt "Extended Command"))
159
160 (defclass weird () ()
161 (:documentation "An open ended class."))
162
163 (define-command com-insert-weird-stuff ()
164 (insert-object (point (win *application-frame*)) (make-instance 'weird)))
165
166 (define-command com-insert-reversed-string ()
167 (insert-sequence (point (win *application-frame*))
168 (reverse (accept 'string))))
169
170 (define-presentation-type completable-pathname ()
171 :inherit-from 'pathname)
172
173 (defun filename-completer (so-far mode)
174 (flet ((remove-trail (s)
175 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
176 (if pos (1+ pos) 0)))))
177 (let* ((directory-prefix
178 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
179 ""
180 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
181 (full-so-far (concatenate 'string directory-prefix so-far))
182 (pathnames
183 (loop with length = (length full-so-far)
184 for path in (directory (concatenate 'string
185 (remove-trail so-far)
186 "*.*"))
187 when (let ((mismatch (mismatch (namestring path) full-so-far)))
188 (or (null mismatch) (= mismatch length)))
189 collect path))
190 (strings (mapcar #'namestring pathnames))
191 (first-string (car strings))
192 (length-common-prefix nil)
193 (completed-string nil)
194 (full-completed-string nil))
195 (unless (null pathnames)
196 (setf length-common-prefix
197 (loop with length = (length first-string)
198 for string in (cdr strings)
199 do (setf length (min length (or (mismatch string first-string) length)))
200 finally (return length))))
201 (unless (null pathnames)
202 (setf completed-string
203 (subseq first-string (length directory-prefix)
204 (if (null (cdr pathnames)) nil length-common-prefix)))
205 (setf full-completed-string
206 (concatenate 'string directory-prefix completed-string)))
207 (case mode
208 ((:complete-limited :complete-maximal)
209 (cond ((null pathnames)
210 (values so-far nil nil 0 nil))
211 ((null (cdr pathnames))
212 (values completed-string t (car pathnames) 1 nil))
213 (t
214 (values completed-string nil nil (length pathnames) nil))))
215 (:complete
216 (cond ((null pathnames)
217 (values so-far nil nil 0 nil))
218 ((null (cdr pathnames))
219 (values completed-string t (car pathnames) 1 nil))
220 ((find full-completed-string strings :test #'string-equal)
221 (let ((pos (position full-completed-string strings :test #'string-equal)))
222 (values completed-string
223 t (elt pathnames pos) (length pathnames) nil)))
224 (t
225 (values completed-string nil nil (length pathnames) nil))))
226 (:possibilities
227 (values nil nil nil (length pathnames)
228 (loop with length = (length directory-prefix)
229 for name in pathnames
230 collect (list (subseq (namestring name) length nil)
231 name))))))))
232
233 (define-presentation-method accept
234 ((type completable-pathname) stream (view textual-view) &key)
235 (multiple-value-bind (pathname success string)
236 (complete-input stream
237 #'filename-completer
238 :partial-completers '(#\Space)
239 :allow-any-input t)
240 (declare (ignore success))
241 (or pathname string)))
242
243 (define-command com-find-file ()
244 (let ((filename (accept 'completable-pathname
245 :prompt "Find File")))
246 (with-slots (buffer point syntax) (win *application-frame*)
247 (setf buffer (make-instance 'climacs-buffer)
248 point (make-instance 'standard-right-sticky-mark :buffer buffer)
249 syntax (make-instance 'texinfo-syntax :pane (win *application-frame*))
250 (filename buffer) filename)
251 (with-open-file (stream filename :direction :input)
252 (input-from-stream stream buffer 0))
253 (beginning-of-buffer point))))
254
255 (define-command com-save-buffer ()
256 (let ((filename (or (filename (buffer (win *application-frame*)))
257 (accept 'completable-pathname
258 :prompt "Save Buffer to File")))
259 (buffer (buffer (win *application-frame*))))
260 (with-open-file (stream filename :direction :output :if-exists :supersede)
261 (output-to-stream stream buffer 0 (size buffer)))))
262
263 (define-command com-beginning-of-buffer ()
264 (beginning-of-buffer (point (win *application-frame*))))
265
266 (define-command com-end-of-buffer ()
267 (end-of-buffer (point (win *application-frame*))))
268
269 (define-command com-browse-url ()
270 (accept 'url :prompt "Browse URL"))
271
272 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
273 ;;;
274 ;;; Global command table
275
276 (make-command-table 'global-climacs-table :errorp nil)
277
278 (defun global-set-key (gesture command)
279 (add-command-to-command-table command 'global-climacs-table
280 :keystroke gesture :errorp nil))
281
282 (loop for code from (char-code #\space) to (char-code #\~)
283 do (global-set-key (code-char code) 'com-self-insert))
284
285 (global-set-key #\newline 'com-self-insert)
286 (global-set-key #\tab 'com-self-insert)
287 (global-set-key '(#\f :control) 'com-forward-object)
288 (global-set-key '(#\b :control) 'com-backward-object)
289 (global-set-key '(#\a :control) 'com-beginning-of-line)
290 (global-set-key '(#\e :control) 'com-end-of-line)
291 (global-set-key '(#\d :control) 'com-delete-object)
292 (global-set-key '(#\p :control) 'com-previous-line)
293 (global-set-key '(#\n :control) 'com-next-line)
294 (global-set-key '(#\o :control) 'com-open-line)
295 (global-set-key '(#\k :control) 'com-kill-line)
296 (global-set-key '(#\f :meta) 'com-forward-word)
297 (global-set-key '(#\b :meta) 'com-backward-word)
298 (global-set-key '(#\x :meta) 'com-extended-command)
299 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
300 (global-set-key '(#\c :meta) 'com-insert-reversed-string)
301 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
302 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
303 (global-set-key '(#\u :meta) 'com-browse-url)
304
305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
306 ;;;
307 ;;; C-x command table
308
309 (make-command-table 'c-x-climacs-table :errorp nil)
310
311 (add-menu-item-to-command-table 'global-climacs-table "C-x"
312 :menu 'c-x-climacs-table
313 :keystroke '(#\x :control))
314
315 (defun c-x-set-key (gesture command)
316 (add-command-to-command-table command 'c-x-climacs-table
317 :keystroke gesture :errorp nil))
318
319 ;;; for some reason, C-c does not seem to arrive as far as CLIM.
320 (c-x-set-key '(#\q :control) 'com-quit)
321 (c-x-set-key '(#\f :control) 'com-find-file)
322 (c-x-set-key '(#\s :control) 'com-save-buffer)

  ViewVC Help
Powered by ViewVC 1.1.5