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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Thu Dec 23 07:01:56 2004 UTC (9 years, 3 months ago) by strandh
Branch: MAIN
Changes since 1.6: +60 -40 lines
Implemented save-buffer.

Made buffer and point part of the pane instead of the frame.  Created
a climacs-pane, subset of application-pane.

Turned abbrevs and filenames into buffer mixins, and defined a
climacs-buffer class.  Removed the abbrev-buffer class.

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

  ViewVC Help
Powered by ViewVC 1.1.5