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

Diff of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.27 by ejohnson, Wed Dec 29 05:55:26 2004 UTC revision 1.28 by rstrandh, Wed Dec 29 06:58:53 2004 UTC
# Line 29  Line 29 
29    
30  (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin)  (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin)
31    ((name :initform "*scratch*" :accessor name)    ((name :initform "*scratch*" :accessor name)
32     (modified :initform nil :accessor modified-p)))     (needs-saving :initform nil :accessor needs-saving)))
33    
34  (defclass climacs-pane (application-pane)  (defclass climacs-pane (application-pane)
35    ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)    ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
# Line 48  Line 48 
48                        :buffer buffer)))                        :buffer buffer)))
49       (setf syntax (make-instance 'texinfo-syntax :pane pane))))       (setf syntax (make-instance 'texinfo-syntax :pane pane))))
50    
51    (defclass minibuffer-pane (application-pane) ())
52    
53    (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
54      (declare (ignore type args))
55      (window-clear pane))
56    
57  (define-application-frame climacs ()  (define-application-frame climacs ()
58    ((win :reader win))    ((win :reader win))
59    (:panes    (:panes
# Line 57  Line 63 
63                     :incremental-redisplay t                     :incremental-redisplay t
64                     :display-function 'display-win))                     :display-function 'display-win))
65      (info :application      (info :application
66           :width 900 :height 20 :max-height 20            :width 900 :height 20 :max-height 20
67           :name 'info :background +light-gray+            :name 'info :background +light-gray+
68           :scroll-bars nil            :scroll-bars nil
69           :incremental-redisplay t            :incremental-redisplay t
70           :display-function 'display-info)            :display-function 'display-info)
71      (int :application :width 900 :height 20 :max-height 20      (int (make-pane 'minibuffer-pane
72           :scroll-bars nil))                      :width 900 :height 20 :max-height 20 :min-height 20
73                        :scroll-bars nil)))
74    (:layouts    (:layouts
75     (default     (default
76         (vertically (:scroll-bars nil)         (vertically (:scroll-bars nil)
# Line 72  Line 79 
79           int)))           int)))
80    (:top-level (climacs-top-level)))    (:top-level (climacs-top-level)))
81    
82    (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
83      (declare (ignore args))
84      (clear-modify (buffer (win frame))))
85    
86  (defun climacs ()  (defun climacs ()
87    "Starts up a climacs session"    "Starts up a climacs session"
88    (let ((frame (make-application-frame 'climacs)))    (let ((frame (make-application-frame 'climacs)))
# Line 81  Line 92 
92    (let* ((win (win frame))    (let* ((win (win frame))
93           (buf (buffer win))           (buf (buffer win))
94           (name-info (format nil "   ~a   ~a"           (name-info (format nil "   ~a   ~a"
95                              (if (modified-p buf) "**" "--")                              (if (needs-saving buf) "**" "--")
96                              (name buf))))                              (name buf))))
97      (princ name-info pane)))      (princ name-info pane)))
98    
# Line 108  Line 119 
119                            partial-command-parser prompt)                            partial-command-parser prompt)
120    (declare (ignore command-parser command-unparser partial-command-parser prompt))    (declare (ignore command-parser command-unparser partial-command-parser prompt))
121    (setf (slot-value frame 'win) (find-pane-named frame 'win))    (setf (slot-value frame 'win) (find-pane-named frame 'win))
 ;;  (let ((*standard-output* (frame-standard-output frame))  
 ;;      (*standard-input* (frame-standard-input frame))  
122    (let ((*standard-output* (find-pane-named frame 'win))    (let ((*standard-output* (find-pane-named frame 'win))
123          (*standard-input* (find-pane-named frame 'int))          (*standard-input* (find-pane-named frame 'int))
124          (*print-pretty* nil)          (*print-pretty* nil)
# Line 140  Line 149 
149                              (format *error-output* "~a~%" condition)))                              (format *error-output* "~a~%" condition)))
150                          (setf gestures '()))                          (setf gestures '()))
151                         (t nil))))                         (t nil))))
152                 (let ((buffer (buffer (win frame))))
153                   (when (modified-p buffer)
154                     (setf (needs-saving buffer) t)))
155               (redisplay-frame-panes frame))))               (redisplay-frame-panes frame))))
156    
157  (define-command (com-quit :name "Quit" :command-table climacs) ()  (define-command (com-quit :name "Quit" :command-table climacs) ()
# Line 148  Line 160 
160  (define-command com-self-insert ()  (define-command com-self-insert ()
161    (unless (constituentp *current-gesture*)    (unless (constituentp *current-gesture*)
162      (possibly-expand-abbrev (point (win *application-frame*))))      (possibly-expand-abbrev (point (win *application-frame*))))
163    (insert-object (point (win *application-frame*)) *current-gesture*)    (insert-object (point (win *application-frame*)) *current-gesture*))
   (setf (modified-p (buffer (win *application-frame*))) t))  
164    
165  (define-command com-backward-object ()  (define-command com-backward-object ()
166    (decf (offset (point (win *application-frame*)))))    (decf (offset (point (win *application-frame*)))))
# Line 164  Line 175 
175    (end-of-line (point (win *application-frame*))))    (end-of-line (point (win *application-frame*))))
176    
177  (define-command com-delete-object ()  (define-command com-delete-object ()
178    (delete-range (point (win *application-frame*)))    (delete-range (point (win *application-frame*))))
   (setf (modified-p (buffer (win *application-frame*))) t))  
179    
180  (define-command com-backward-delete-object ()  (define-command com-backward-delete-object ()
181    (delete-range (point (win *application-frame*)) -1)    (delete-range (point (win *application-frame*)) -1))
   (setf (modified-p (buffer (win *application-frame*))) t))  
182    
183  (define-command com-previous-line ()  (define-command com-previous-line ()
184    (previous-line (point (win *application-frame*))))    (previous-line (point (win *application-frame*))))
# Line 178  Line 187 
187    (next-line (point (win *application-frame*))))    (next-line (point (win *application-frame*))))
188    
189  (define-command com-open-line ()  (define-command com-open-line ()
190    (open-line (point (win *application-frame*)))    (open-line (point (win *application-frame*))))
   (setf (modified-p (buffer (win *application-frame*))) t))  
191    
192  (define-command com-kill-line ()  (define-command com-kill-line ()
193    (kill-line (point (win *application-frame*)))    (kill-line (point (win *application-frame*))))
   (setf (modified-p (buffer (win *application-frame*))) t))  
194    
195  (define-command com-forward-word ()  (define-command com-forward-word ()
196    (forward-word (point (win *application-frame*))))    (forward-word (point (win *application-frame*))))
# Line 199  Line 206 
206    
207  (define-command com-extended-command ()  (define-command com-extended-command ()
208    (let ((item (accept 'command :prompt "Extended Command")))    (let ((item (accept 'command :prompt "Extended Command")))
     (window-clear *standard-input*)  
209      (execute-frame-command *application-frame* item)))      (execute-frame-command *application-frame* item)))
210    
 (defclass weird () ()  
   (:documentation "An open ended class."))  
   
 (define-command com-insert-weird-stuff ()  
   (insert-object (point (win *application-frame*)) (make-instance 'weird))  
   (setf (modified-p (buffer (win *application-frame*))) t))  
   
 (define-command com-insert-reversed-string ()  
   (insert-sequence (point (win *application-frame*))  
                    (reverse (accept 'string)))  
   (setf (modified-p (buffer (win *application-frame*))) t))  
   
211  (define-presentation-type completable-pathname ()  (define-presentation-type completable-pathname ()
212    :inherit-from 'pathname)    :inherit-from 'pathname)
213    
# Line 303  Line 297 
297         (with-open-file (stream filename :direction :input :if-does-not-exist :create)         (with-open-file (stream filename :direction :input :if-does-not-exist :create)
298           (input-from-stream stream buffer 0))           (input-from-stream stream buffer 0))
299         (setf (filename buffer) filename         (setf (filename buffer) filename
300               (name buffer) (pathname-filename filename))               (name buffer) (pathname-filename filename)
301                 (needs-saving buffer) nil)
302           ;; this one is needed so that the buffer modification protocol
303           ;; resets the low and high marks after redisplay
304           (redisplay-frame-panes *application-frame*)
305         (beginning-of-buffer point))))         (beginning-of-buffer point))))
306    
307  (define-command com-save-buffer ()  (define-command com-save-buffer ()
# Line 314  Line 312 
312      (with-open-file (stream filename :direction :output :if-exists :supersede)      (with-open-file (stream filename :direction :output :if-exists :supersede)
313        (output-to-stream stream buffer 0 (size buffer)))        (output-to-stream stream buffer 0 (size buffer)))
314      (setf (filename buffer) filename      (setf (filename buffer) filename
315            (name buffer) (pathname-filename filename))            (name buffer) (pathname-filename filename)
316      (setf (modified-p (buffer (win *application-frame*))) nil)))            (needs-saving buffer) nil)))
317    
318  (define-command com-write-buffer ()  (define-command com-write-buffer ()
319    (let ((filename (accept 'completable-pathname    (let ((filename (accept 'completable-pathname
# Line 324  Line 322 
322      (with-open-file (stream filename :direction :output :if-exists :supersede)      (with-open-file (stream filename :direction :output :if-exists :supersede)
323        (output-to-stream stream buffer 0 (size buffer)))        (output-to-stream stream buffer 0 (size buffer)))
324      (setf (filename buffer) filename      (setf (filename buffer) filename
325            (name buffer) (pathname-filename filename))            (name buffer) (pathname-filename filename)
326      (setf (modified-p (buffer (win *application-frame*))) nil)))            (needs-saving buffer) nil)))
327    
328  (define-command com-beginning-of-buffer ()  (define-command com-beginning-of-buffer ()
329    (beginning-of-buffer (point (win *application-frame*))))    (beginning-of-buffer (point (win *application-frame*))))
# Line 409  Line 407 
407  (global-set-key '(#\f :meta) 'com-forward-word)  (global-set-key '(#\f :meta) 'com-forward-word)
408  (global-set-key '(#\b :meta) 'com-backward-word)  (global-set-key '(#\b :meta) 'com-backward-word)
409  (global-set-key '(#\x :meta) 'com-extended-command)  (global-set-key '(#\x :meta) 'com-extended-command)
 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)  
 (global-set-key '(#\c :meta) 'com-insert-reversed-string)  
410  (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only  (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only
411  (global-set-key '(#\w :meta) 'com-copy-out)  (global-set-key '(#\w :meta) 'com-copy-out)
412  (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)  (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

  ViewVC Help
Powered by ViewVC 1.1.5