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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Thu Dec 23 16:37:08 2004 UTC (9 years, 4 months ago) by rstrandh
Branch: MAIN
Changes since 1.9: +12 -4 lines
Rendering of #\Tab characters works.

Replaced occurrences of (win frame) by pane in display function.

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

  ViewVC Help
Powered by ViewVC 1.1.5