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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Dec 21 18:36:31 2004 UTC (9 years, 3 months ago) by strandh
Branch: MAIN
Changes since 1.3: +10 -5 lines
Improved error checking.
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 (cursor-x nil)
57 (cursor-y nil))
58 (flet ((display-line ()
59 (loop with offset1 = nil
60 when (= offset (offset (point frame)))
61 do (multiple-value-bind (x y) (stream-cursor-position pane)
62 (setf cursor-x (+ x (if (null offset1)
63 0
64 (* width (- offset offset1))))
65 cursor-y y))
66 when (= offset size)
67 do (unless (null offset1)
68 (present (buffer-sequence buffer offset1 offset) 'string :stream pane)
69 (setf offset1 nil))
70 (return)
71 until (eql (buffer-object buffer offset) #\Newline)
72 do (let ((obj (buffer-object buffer offset)))
73 (cond ((eql obj #\Space)
74 (unless (null offset1)
75 (princ (buffer-sequence buffer offset1 offset) pane)
76 (setf offset1 nil))
77 (princ obj pane))
78 ((constituentp obj)
79 (when (null offset1)
80 (setf offset1 offset)))
81 (t
82 (unless (null offset1)
83 (princ (buffer-sequence buffer offset1 offset) pane)
84 (setf offset1 nil))
85 (princ obj pane))))
86 (incf offset)
87 finally (unless (null offset1)
88 (princ (buffer-sequence buffer offset1 offset) pane)
89 (setf offset1 nil))
90 (incf offset)
91 (terpri pane))))
92 (loop while (< offset size)
93 do (display-line))
94 (when (= offset (offset (point frame)))
95 (multiple-value-bind (x y) (stream-cursor-position pane)
96 (setf cursor-x x
97 cursor-y y))))
98 (draw-line* pane
99 cursor-x (- cursor-y (* 0.2 height))
100 cursor-x (+ cursor-y (* 0.8 height))
101 :ink +red+)))
102
103 (defun find-gestures (gestures start-table)
104 (loop with table = (find-command-table start-table)
105 for (gesture . rest) on gestures
106 for item = (find-keystroke-item gesture table :errorp nil)
107 while item
108 do (if (eq (command-menu-item-type item) :command)
109 (return (if (null rest) item nil))
110 (setf table (command-menu-item-value item)))
111 finally (return item)))
112
113 (defparameter *current-gesture* nil)
114
115 (defun climacs-top-level (frame &key
116 command-parser command-unparser
117 partial-command-parser prompt)
118 (declare (ignore command-parser command-unparser partial-command-parser prompt))
119 (let ((*standard-output* (frame-standard-output frame))
120 (*standard-input* (frame-standard-input frame))
121 (*print-pretty* nil))
122 (redisplay-frame-panes frame :force-p t)
123 (loop with gestures = '()
124 do (setf *current-gesture* (read-gesture :stream *standard-input*))
125 (when (or (characterp *current-gesture*)
126 (keyboard-event-character *current-gesture*))
127 (setf gestures (nconc gestures (list *current-gesture*)))
128 (let ((item (find-gestures gestures 'global-climacs-table)))
129 (cond ((not item)
130 (beep) (setf gestures '()))
131 ((eq (command-menu-item-type item) :command)
132 (handler-case
133 (funcall (command-menu-item-value item))
134 (error (condition)
135 (beep)
136 (format *error-output* "~a~%" condition)))
137 (setf gestures '()))
138 (t nil))))
139 (redisplay-frame-panes frame :force-p t))))
140
141 (define-command com-quit ()
142 (frame-exit *application-frame*))
143
144 (define-command com-self-insert ()
145 (unless (constituentp *current-gesture*)
146 (possibly-expand-abbrev (point *application-frame*)))
147 (insert-object (point *application-frame*) *current-gesture*))
148
149 (define-command com-backward-object ()
150 (decf (offset (point *application-frame*))))
151
152 (define-command com-forward-object ()
153 (incf (offset (point *application-frame*))))
154
155 (define-command com-beginning-of-line ()
156 (beginning-of-line (point *application-frame*)))
157
158 (define-command com-end-of-line ()
159 (end-of-line (point *application-frame*)))
160
161 (define-command com-delete-object ()
162 (delete-range (point *application-frame*)))
163
164 (define-command com-previous-line ()
165 (previous-line (point *application-frame*)))
166
167 (define-command com-next-line ()
168 (next-line (point *application-frame*)))
169
170 (define-command com-open-line ()
171 (open-line (point *application-frame*)))
172
173 (define-command com-kill-line ()
174 (kill-line (point *application-frame*)))
175
176 (define-command com-forward-word ()
177 (forward-word (point *application-frame*)))
178
179 (define-command com-backward-word ()
180 (backward-word (point *application-frame*)))
181
182 (define-command com-toggle-layout ()
183 (setf (frame-current-layout *application-frame*)
184 (if (eq (frame-current-layout *application-frame*) 'default)
185 'with-interactor
186 'default)))
187
188 (define-command com-extended-command ()
189 (accept 'command :prompt "Extended Command"))
190
191 (defclass weird () ())
192
193 (define-command com-insert-weird-stuff ()
194 (insert-object (point *application-frame*) (make-instance 'weird)))
195
196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 ;;;
198 ;;; Global command table
199
200 (make-command-table 'global-climacs-table :errorp nil)
201
202 (defun global-set-key (gesture command)
203 (add-command-to-command-table command 'global-climacs-table
204 :keystroke gesture :errorp nil))
205
206 (loop for code from (char-code #\space) to (char-code #\~)
207 do (global-set-key (code-char code) 'com-self-insert))
208
209 (global-set-key #\newline 'com-self-insert)
210 (global-set-key '(#\f :control) 'com-forward-object)
211 (global-set-key '(#\b :control) 'com-backward-object)
212 (global-set-key '(#\a :control) 'com-beginning-of-line)
213 (global-set-key '(#\e :control) 'com-end-of-line)
214 (global-set-key '(#\d :control) 'com-delete-object)
215 (global-set-key '(#\p :control) 'com-previous-line)
216 (global-set-key '(#\n :control) 'com-next-line)
217 (global-set-key '(#\o :control) 'com-open-line)
218 (global-set-key '(#\k :control) 'com-kill-line)
219 (global-set-key '(#\f :meta) 'com-forward-word)
220 (global-set-key '(#\b :meta) 'com-backward-word)
221 (global-set-key '(#\x :meta) 'com-extended-command)
222 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
223
224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
225 ;;;
226 ;;; C-x command table
227
228 (make-command-table 'c-x-climacs-table :errorp nil)
229
230 (add-menu-item-to-command-table 'global-climacs-table "C-x"
231 :menu 'c-x-climacs-table
232 :keystroke '(#\x :control))
233
234 ;;; for some reason, C-c does not seem to arrive as far as CLIM.
235
236 (add-command-to-command-table 'com-quit 'c-x-climacs-table
237 :keystroke '(#\q :control))
238
239

  ViewVC Help
Powered by ViewVC 1.1.5