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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Wed Dec 22 05:38:05 2004 UTC (9 years, 3 months ago) by strandh
Branch: MAIN
Changes since 1.4: +109 -15 lines
Added find-file.
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 (define-application-frame climacs ()
26 ((buffer :initform (make-instance 'abbrev-buffer)
27 :accessor buffer)
28 (point :initform nil :reader point))
29 (:panes
30 (win :application :width 600 :height 400
31 :display-function 'display-win)
32 (int :interactor :width 600 :height 50))
33 (:layouts
34 (default
35 (vertically () win int)))
36 (:top-level (climacs-top-level)))
37
38 (defmethod initialize-instance :after ((frame climacs) &rest args)
39 (declare (ignore args))
40 (setf (slot-value frame 'point)
41 (make-instance 'standard-right-sticky-mark
42 :buffer (buffer frame))))
43
44 (defun climacs ()
45 (let ((frame (make-application-frame 'climacs)))
46 (run-frame-top-level frame)))
47
48 (defun display-win (frame pane)
49 (let* ((medium (sheet-medium pane))
50 (style (medium-text-style medium))
51 (height (text-style-height style medium))
52 (width (text-style-width style medium))
53 (buffer (buffer frame))
54 (size (size (buffer frame)))
55 (offset 0)
56 (offset1 nil)
57 (cursor-x nil)
58 (cursor-y nil))
59 (labels ((present-contents ()
60 (unless (null offset1)
61 (present (coerce (buffer-sequence buffer offset1 offset) 'string)
62 'string
63 :stream pane)
64 (setf offset1 nil)))
65 (display-line ()
66 (loop when (= offset (offset (point frame)))
67 do (multiple-value-bind (x y) (stream-cursor-position pane)
68 (setf cursor-x (+ x (if (null offset1)
69 0
70 (* width (- offset offset1))))
71 cursor-y y))
72 when (= offset size)
73 do (present-contents)
74 (return)
75 until (eql (buffer-object buffer offset) #\Newline)
76 do (let ((obj (buffer-object buffer offset)))
77 (cond ((eql obj #\Space)
78 (present-contents)
79 (princ obj pane))
80 ((constituentp obj)
81 (when (null offset1)
82 (setf offset1 offset)))
83 (t
84 (present-contents)
85 (princ obj pane))))
86 (incf offset)
87 finally (present-contents)
88 (incf offset)
89 (terpri pane))))
90 (loop while (< offset size)
91 do (display-line))
92 (when (= offset (offset (point frame)))
93 (multiple-value-bind (x y) (stream-cursor-position pane)
94 (setf cursor-x x
95 cursor-y y))))
96 (draw-line* pane
97 cursor-x (- cursor-y (* 0.2 height))
98 cursor-x (+ cursor-y (* 0.8 height))
99 :ink +red+)))
100
101 (defun find-gestures (gestures start-table)
102 (loop with table = (find-command-table start-table)
103 for (gesture . rest) on gestures
104 for item = (find-keystroke-item gesture table :errorp nil)
105 while item
106 do (if (eq (command-menu-item-type item) :command)
107 (return (if (null rest) item nil))
108 (setf table (command-menu-item-value item)))
109 finally (return item)))
110
111 (defparameter *current-gesture* nil)
112
113 (defun climacs-top-level (frame &key
114 command-parser command-unparser
115 partial-command-parser prompt)
116 (declare (ignore command-parser command-unparser partial-command-parser prompt))
117 (let ((*standard-output* (frame-standard-output frame))
118 (*standard-input* (frame-standard-input frame))
119 (*print-pretty* nil))
120 (redisplay-frame-panes frame :force-p t)
121 (loop with gestures = '()
122 do (setf *current-gesture* (read-gesture :stream *standard-input*))
123 (when (or (characterp *current-gesture*)
124 (keyboard-event-character *current-gesture*))
125 (setf gestures (nconc gestures (list *current-gesture*)))
126 (let ((item (find-gestures gestures 'global-climacs-table)))
127 (cond ((not item)
128 (beep) (setf gestures '()))
129 ((eq (command-menu-item-type item) :command)
130 (handler-case
131 (funcall (command-menu-item-value item))
132 (error (condition)
133 (beep)
134 (format *error-output* "~a~%" condition)))
135 (setf gestures '()))
136 (t nil))))
137 (redisplay-frame-panes frame :force-p t))))
138
139 (define-command com-quit ()
140 (frame-exit *application-frame*))
141
142 (define-command com-self-insert ()
143 (unless (constituentp *current-gesture*)
144 (possibly-expand-abbrev (point *application-frame*)))
145 (insert-object (point *application-frame*) *current-gesture*))
146
147 (define-command com-backward-object ()
148 (decf (offset (point *application-frame*))))
149
150 (define-command com-forward-object ()
151 (incf (offset (point *application-frame*))))
152
153 (define-command com-beginning-of-line ()
154 (beginning-of-line (point *application-frame*)))
155
156 (define-command com-end-of-line ()
157 (end-of-line (point *application-frame*)))
158
159 (define-command com-delete-object ()
160 (delete-range (point *application-frame*)))
161
162 (define-command com-previous-line ()
163 (previous-line (point *application-frame*)))
164
165 (define-command com-next-line ()
166 (next-line (point *application-frame*)))
167
168 (define-command com-open-line ()
169 (open-line (point *application-frame*)))
170
171 (define-command com-kill-line ()
172 (kill-line (point *application-frame*)))
173
174 (define-command com-forward-word ()
175 (forward-word (point *application-frame*)))
176
177 (define-command com-backward-word ()
178 (backward-word (point *application-frame*)))
179
180 (define-command com-toggle-layout ()
181 (setf (frame-current-layout *application-frame*)
182 (if (eq (frame-current-layout *application-frame*) 'default)
183 'with-interactor
184 'default)))
185
186 (define-command com-extended-command ()
187 (accept 'command :prompt "Extended Command"))
188
189 (defclass weird () ())
190
191 (define-command com-insert-weird-stuff ()
192 (insert-object (point *application-frame*) (make-instance 'weird)))
193
194 (define-command com-insert-number ()
195 (insert-sequence (point *application-frame*)
196 (format nil "~a" (accept 'number :prompt "Insert Number"))))
197
198 (define-presentation-type completable-pathname ()
199 :inherit-from 'pathname)
200
201 (defun filename-completer (so-far mode)
202 (flet ((remove-trail (s)
203 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
204 (if pos (1+ pos) 0)))))
205 (let* ((directory-prefix
206 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
207 ""
208 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
209 (full-so-far (concatenate 'string directory-prefix so-far))
210 (pathnames
211 (loop with length = (length full-so-far)
212 for path in (directory (concatenate 'string
213 (remove-trail so-far)
214 "*.*"))
215 when (let ((mismatch (mismatch (namestring path) full-so-far)))
216 (or (null mismatch) (= mismatch length)))
217 collect path))
218 (strings (mapcar #'namestring pathnames))
219 (first-string (car strings))
220 (length-common-prefix nil)
221 (completed-string nil)
222 (full-completed-string nil))
223 (unless (null pathnames)
224 (setf length-common-prefix
225 (loop with length = (length first-string)
226 for string in (cdr strings)
227 do (setf length (min length (or (mismatch string first-string) length)))
228 finally (return length))))
229 (unless (null pathnames)
230 (setf completed-string
231 (subseq first-string (length directory-prefix)
232 (if (null (cdr pathnames)) nil length-common-prefix)))
233 (setf full-completed-string
234 (concatenate 'string directory-prefix completed-string)))
235 (case mode
236 ((:complete-limited :complete-maximal)
237 (cond ((null pathnames)
238 (values so-far nil nil 0 nil))
239 ((null (cdr pathnames))
240 (values completed-string t (car pathnames) 1 nil))
241 (t
242 (values completed-string nil nil (length pathnames) nil))))
243 (:complete
244 (cond ((null pathnames)
245 (values so-far nil nil 0 nil))
246 ((null (cdr pathnames))
247 (values completed-string t (car pathnames) 1 nil))
248 ((find full-completed-string strings :test #'string-equal)
249 (let ((pos (position full-completed-string strings :test #'string-equal)))
250 (values completed-string
251 t (elt pathnames pos) (length pathnames) nil)))
252 (t
253 (values completed-string nil nil (length pathnames) nil))))
254 (:possibilities
255 (values nil nil nil (length pathnames)
256 (loop with length = (length directory-prefix)
257 for name in pathnames
258 collect (list (subseq (namestring name) length nil)
259 name))))))))
260
261 (define-presentation-method accept
262 ((type completable-pathname) stream (view textual-view) &key)
263 (multiple-value-bind (pathname success string)
264 (complete-input stream
265 #'filename-completer
266 :partial-completers '(#\Space)
267 :allow-any-input t)
268 (declare (ignore success))
269 (or pathname string)))
270
271 (define-command com-find-file ()
272 (let ((filename (handler-case (accept 'completable-pathname
273 :prompt "Find File")
274 (simple-parse-error () (error 'file-not-found)))))
275 (setf (buffer *application-frame*)
276 (make-instance 'abbrev-buffer
277 :contents (cons nil
278 (with-open-file (stream filename :direction :input)
279 (loop for ch = (read-char stream nil nil)
280 while ch
281 collect ch)))))
282 (setf (slot-value *application-frame* 'point)
283 (make-instance 'standard-right-sticky-mark
284 :buffer (buffer *application-frame*)))))
285
286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
287 ;;;
288 ;;; Global command table
289
290 (make-command-table 'global-climacs-table :errorp nil)
291
292 (defun global-set-key (gesture command)
293 (add-command-to-command-table command 'global-climacs-table
294 :keystroke gesture :errorp nil))
295
296 (loop for code from (char-code #\space) to (char-code #\~)
297 do (global-set-key (code-char code) 'com-self-insert))
298
299 (global-set-key #\newline 'com-self-insert)
300 (global-set-key '(#\f :control) 'com-forward-object)
301 (global-set-key '(#\b :control) 'com-backward-object)
302 (global-set-key '(#\a :control) 'com-beginning-of-line)
303 (global-set-key '(#\e :control) 'com-end-of-line)
304 (global-set-key '(#\d :control) 'com-delete-object)
305 (global-set-key '(#\p :control) 'com-previous-line)
306 (global-set-key '(#\n :control) 'com-next-line)
307 (global-set-key '(#\o :control) 'com-open-line)
308 (global-set-key '(#\k :control) 'com-kill-line)
309 (global-set-key '(#\f :meta) 'com-forward-word)
310 (global-set-key '(#\b :meta) 'com-backward-word)
311 (global-set-key '(#\x :meta) 'com-extended-command)
312 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
313 (global-set-key '(#\c :meta) 'com-insert-number)
314
315 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
316 ;;;
317 ;;; C-x command table
318
319 (make-command-table 'c-x-climacs-table :errorp nil)
320
321 (add-menu-item-to-command-table 'global-climacs-table "C-x"
322 :menu 'c-x-climacs-table
323 :keystroke '(#\x :control))
324
325 ;;; for some reason, C-c does not seem to arrive as far as CLIM.
326
327 (add-command-to-command-table 'com-quit 'c-x-climacs-table
328 :keystroke '(#\q :control))
329
330 (add-command-to-command-table 'com-find-file 'c-x-climacs-table
331 :keystroke '(#\f :control))
332
333

  ViewVC Help
Powered by ViewVC 1.1.5