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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Dec 21 16:19:26 2004 UTC (9 years, 3 months ago) by strandh
Branch: MAIN
Changes since 1.2: +79 -26 lines
I am now convinced the buffer can contain arbitrary objects.  I
therefore updated the protocol descriptions and the code to reflect
that.
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 100))
33 (:layouts
34 (default
35 (vertically () win))
36 (with-interactor
37 (vertically () win int)))
38 (:top-level (climacs-top-level)))
39
40 (defmethod initialize-instance :after ((frame climacs) &rest args)
41 (declare (ignore args))
42 (setf (slot-value frame 'point)
43 (make-instance 'standard-right-sticky-mark
44 :buffer (buffer frame))))
45
46 (defun climacs ()
47 (let ((frame (make-application-frame 'climacs)))
48 (run-frame-top-level frame)))
49
50 (defun display-win (frame pane)
51 (let* ((medium (sheet-medium pane))
52 (style (medium-text-style medium))
53 (height (text-style-height style medium))
54 (width (text-style-width style medium))
55 (buffer (buffer frame))
56 (size (size (buffer frame)))
57 (offset 0)
58 (cursor-x nil)
59 (cursor-y nil))
60 (flet ((display-line ()
61 (loop with offset1 = nil
62 when (= offset (offset (point frame)))
63 do (multiple-value-bind (x y) (stream-cursor-position pane)
64 (setf cursor-x (+ x (if (null offset1)
65 0
66 (* width (- offset offset1))))
67 cursor-y y))
68 when (= offset size)
69 do (unless (null offset1)
70 (present (buffer-sequence buffer offset1 offset) 'string :stream pane)
71 (setf offset1 nil))
72 (return)
73 until (eql (buffer-object buffer offset) #\Newline)
74 do (let ((obj (buffer-object buffer offset)))
75 (cond ((eql obj #\Space)
76 (unless (null offset1)
77 (princ (buffer-sequence buffer offset1 offset) pane)
78 (setf offset1 nil))
79 (princ obj pane))
80 ((constituentp obj)
81 (when (null offset1)
82 (setf offset1 offset)))
83 (t
84 (unless (null offset1)
85 (princ (buffer-sequence buffer offset1 offset) pane)
86 (setf offset1 nil))
87 (princ obj pane))))
88 (incf offset)
89 finally (unless (null offset1)
90 (princ (buffer-sequence buffer offset1 offset) pane)
91 (setf offset1 nil))
92 (incf offset)
93 (terpri pane))))
94 (loop while (< offset size)
95 do (display-line))
96 (when (= offset (offset (point frame)))
97 (multiple-value-bind (x y) (stream-cursor-position pane)
98 (setf cursor-x x
99 cursor-y y))))
100 (draw-line* pane
101 cursor-x (- cursor-y (* 0.2 height))
102 cursor-x (+ cursor-y (* 0.8 height))
103 :ink +red+)))
104
105 (defun find-gestures (gestures start-table)
106 (loop with table = (find-command-table start-table)
107 for (gesture . rest) on gestures
108 for item = (find-keystroke-item gesture table :errorp nil)
109 while item
110 do (if (eq (command-menu-item-type item) :command)
111 (return (if (null rest) item nil))
112 (setf table (command-menu-item-value item)))
113 finally (return item)))
114
115 (defparameter *current-gesture* nil)
116
117 (defun climacs-top-level (frame &key
118 command-parser command-unparser
119 partial-command-parser prompt)
120 (declare (ignore command-parser command-unparser partial-command-parser prompt))
121 (let ((*standard-output* (frame-standard-output frame))
122 (*standard-input* (frame-standard-input frame))
123 (*print-pretty* nil))
124 (redisplay-frame-panes frame :force-p t)
125 (loop with gestures = '()
126 do (setf *current-gesture* (read-gesture :stream *standard-input*))
127 (when (or (characterp *current-gesture*)
128 (keyboard-event-character *current-gesture*))
129 (setf gestures (nconc gestures (list *current-gesture*)))
130 (let ((item (find-gestures gestures 'global-climacs-table)))
131 (cond ((not item)
132 (beep) (setf gestures '()))
133 ((eq (command-menu-item-type item) :command)
134 (funcall (command-menu-item-value item))
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 (defclass weird () ())
187
188 (define-command com-insert-weird-stuff ()
189 (insert-object (point *application-frame*) (make-instance 'weird)))
190
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
192 ;;;
193 ;;; Global command table
194
195 (make-command-table 'global-climacs-table :errorp nil)
196
197 (defun global-set-key (gesture command)
198 (add-command-to-command-table command 'global-climacs-table
199 :keystroke gesture :errorp nil))
200
201 (loop for code from (char-code #\space) to (char-code #\~)
202 do (global-set-key (code-char code) 'com-self-insert))
203
204 (global-set-key #\newline 'com-self-insert)
205 (global-set-key '(#\f :control) 'com-forward-object)
206 (global-set-key '(#\b :control) 'com-backward-object)
207 (global-set-key '(#\a :control) 'com-beginning-of-line)
208 (global-set-key '(#\e :control) 'com-end-of-line)
209 (global-set-key '(#\d :control) 'com-delete-object)
210 (global-set-key '(#\p :control) 'com-previous-line)
211 (global-set-key '(#\n :control) 'com-next-line)
212 (global-set-key '(#\o :control) 'com-open-line)
213 (global-set-key '(#\k :control) 'com-kill-line)
214 (global-set-key '(#\f :meta) 'com-forward-word)
215 (global-set-key '(#\b :meta) 'com-backward-word)
216 (global-set-key '(#\x :meta) 'com-toggle-layout)
217 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
218
219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220 ;;;
221 ;;; C-x command table
222
223 (make-command-table 'c-x-climacs-table :errorp nil)
224
225 (add-menu-item-to-command-table 'global-climacs-table "C-x"
226 :menu 'c-x-climacs-table
227 :keystroke '(#\x :control))
228
229 ;;; for some reason, C-c does not seem to arrive as far as CLIM.
230
231 (add-command-to-command-table 'com-quit 'c-x-climacs-table
232 :keystroke '(#\q :control))
233
234

  ViewVC Help
Powered by ViewVC 1.1.5