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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide 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 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 strandh 1.4 (int :interactor :width 600 :height 50))
33 strandh 1.1 (:layouts
34 strandh 1.3 (default
35     (vertically () win int)))
36 strandh 1.1 (: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 strandh 1.2 (let ((frame (make-application-frame 'climacs)))
46     (run-frame-top-level frame)))
47 strandh 1.1
48     (defun display-win (frame pane)
49     (let* ((medium (sheet-medium pane))
50     (style (medium-text-style medium))
51 strandh 1.3 (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 strandh 1.1
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 strandh 1.4 (handler-case
133     (funcall (command-menu-item-value item))
134     (error (condition)
135     (beep)
136     (format *error-output* "~a~%" condition)))
137 strandh 1.1 (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 strandh 1.2 (unless (constituentp *current-gesture*)
146     (possibly-expand-abbrev (point *application-frame*)))
147 strandh 1.3 (insert-object (point *application-frame*) *current-gesture*))
148 strandh 1.1
149 strandh 1.3 (define-command com-backward-object ()
150 strandh 1.1 (decf (offset (point *application-frame*))))
151    
152 strandh 1.3 (define-command com-forward-object ()
153 strandh 1.1 (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 strandh 1.3 (define-command com-delete-object ()
162     (delete-range (point *application-frame*)))
163 strandh 1.1
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 strandh 1.3 (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 strandh 1.4 (define-command com-extended-command ()
189     (accept 'command :prompt "Extended Command"))
190    
191 strandh 1.3 (defclass weird () ())
192    
193     (define-command com-insert-weird-stuff ()
194     (insert-object (point *application-frame*) (make-instance 'weird)))
195    
196 strandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 strandh 1.3 (global-set-key '(#\f :control) 'com-forward-object)
211     (global-set-key '(#\b :control) 'com-backward-object)
212 strandh 1.1 (global-set-key '(#\a :control) 'com-beginning-of-line)
213     (global-set-key '(#\e :control) 'com-end-of-line)
214 strandh 1.3 (global-set-key '(#\d :control) 'com-delete-object)
215 strandh 1.1 (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 strandh 1.4 (global-set-key '(#\x :meta) 'com-extended-command)
222 strandh 1.3 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
223 strandh 1.1
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