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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide 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 strandh 1.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 strandh 1.2 ((buffer :initform (make-instance 'abbrev-buffer)
27 strandh 1.1 :accessor buffer)
28     (point :initform nil :reader point))
29     (:panes
30 strandh 1.3 (win :application :width 600 :height 400
31     :display-function 'display-win)
32     (int :interactor :width 600 :height 100))
33 strandh 1.1 (:layouts
34 strandh 1.3 (default
35     (vertically () win))
36     (with-interactor
37     (vertically () win int)))
38 strandh 1.1 (: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 strandh 1.2 (let ((frame (make-application-frame 'climacs)))
48     (run-frame-top-level frame)))
49 strandh 1.1
50     (defun display-win (frame pane)
51     (let* ((medium (sheet-medium pane))
52     (style (medium-text-style medium))
53 strandh 1.3 (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 strandh 1.1
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 strandh 1.2 (unless (constituentp *current-gesture*)
144     (possibly-expand-abbrev (point *application-frame*)))
145 strandh 1.3 (insert-object (point *application-frame*) *current-gesture*))
146 strandh 1.1
147 strandh 1.3 (define-command com-backward-object ()
148 strandh 1.1 (decf (offset (point *application-frame*))))
149    
150 strandh 1.3 (define-command com-forward-object ()
151 strandh 1.1 (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 strandh 1.3 (define-command com-delete-object ()
160     (delete-range (point *application-frame*)))
161 strandh 1.1
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 strandh 1.3 (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 strandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 strandh 1.3 (global-set-key '(#\f :control) 'com-forward-object)
206     (global-set-key '(#\b :control) 'com-backward-object)
207 strandh 1.1 (global-set-key '(#\a :control) 'com-beginning-of-line)
208     (global-set-key '(#\e :control) 'com-end-of-line)
209 strandh 1.3 (global-set-key '(#\d :control) 'com-delete-object)
210 strandh 1.1 (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 strandh 1.3 (global-set-key '(#\x :meta) 'com-toggle-layout)
217     (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
218 strandh 1.1
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