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

Diff of /climacs/gui.lisp

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

revision 1.223 by thenriksen, Mon Jul 24 13:24:40 2006 UTC revision 1.224 by thenriksen, Mon Jul 24 16:33:16 2006 UTC
# Line 37  Line 37 
37     (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)     (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)
38     (overwrite-mode :initform nil :accessor overwrite-mode)))     (overwrite-mode :initform nil :accessor overwrite-mode)))
39    
40    (defclass typeout-pane (application-pane esa-pane-mixin)
41      ())
42    
43  (defgeneric buffer-pane-p (pane)  (defgeneric buffer-pane-p (pane)
44    (:documentation "Returns T when a pane contains a buffer."))    (:documentation "Returns T when a pane contains a buffer."))
45    
# Line 124  Line 127 
127  (defvar *mini-bg-color* +white+)  (defvar *mini-bg-color* +white+)
128  (defvar *mini-fg-color* +black+)  (defvar *mini-fg-color* +black+)
129    
   
130  (define-application-frame climacs (standard-application-frame  (define-application-frame climacs (standard-application-frame
131                                     esa-frame-mixin)                                     esa-frame-mixin)
132    ((buffers :initform '() :accessor buffers))    ((buffers :initform '() :accessor buffers)
133       (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring))
134    (:command-table (global-climacs-table    (:command-table (global-climacs-table
135                     :inherit-from (global-esa-table                     :inherit-from (global-esa-table
136                                    keyboard-macro-table                                    keyboard-macro-table
# Line 184  Line 187 
187         (vertically (:scroll-bars nil)         (vertically (:scroll-bars nil)
188           climacs-window           climacs-window
189           minibuffer)))           minibuffer)))
190    (:top-level (esa-top-level :prompt "M-x ")))    (:top-level ((lambda (frame)
191                     (let ((*kill-ring* (kill-ring frame)))
192                       (esa-top-level frame :prompt "M-x "))))))
193    
194  (defmethod frame-standard-input ((frame climacs))  (defmethod frame-standard-input ((frame climacs))
195    (get-frame-pane frame 'minibuffer))    (get-frame-pane frame 'minibuffer))
# Line 380  Signals and error if the file does not e Line 385  Signals and error if the file does not e
385           'self-insert-table           'self-insert-table
386           '((#\Newline)))           '((#\Newline)))
387    
388  ;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
389  ;;; Pane commands  ;;;
390    ;;; Pane/buffer functions
391    
392    (defun replace-constellation (constellation additional-constellation vertical-p)
393      (let* ((parent (sheet-parent constellation))
394             (children (sheet-children parent))
395             (first (first children))
396             (second (second children))
397             (third (third children))
398             (first-split-p (= (length (sheet-children parent)) 2))
399             (parent-region (sheet-region parent))
400             (parent-height (rectangle-height parent-region))
401             (parent-width (rectangle-width parent-region))
402             (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing.
403             (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget)))
404        (assert (member constellation children))
405    
406        (when first-split-p (setf (sheet-region filler) (sheet-region parent))
407          (sheet-adopt-child parent filler))
408    
409        (sheet-disown-child parent constellation)
410    
411        (if vertical-p
412            (resize-sheet constellation parent-width (/ parent-height 2))
413            (resize-sheet constellation  (/ parent-width 2) parent-height))
414    
415        (let ((new (if vertical-p
416                       (vertically ()
417                         constellation adjust additional-constellation)
418                       (horizontally ()
419                         constellation adjust additional-constellation))))
420          (sheet-adopt-child parent new)
421    
422          (when first-split-p (sheet-disown-child parent filler))
423          (reorder-sheets parent
424                          (if (eq constellation first)
425                              (if third
426                                  (list new second third)
427                                  (list new second))
428                              (if third
429                                  (list first second new)
430                                  (list first new)))))))
431    (defun find-parent (sheet)
432      (loop for parent = (sheet-parent sheet)
433              then (sheet-parent parent)
434            until (typep parent 'vrack-pane)
435            finally (return parent)))
436    
437    (defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*))
438      "make a vbox containing a scroller pane as its first child and an
439    info pane as its second child.  The scroller pane contains a viewport
440    which contains an extended pane.  Return the vbox and the extended pane
441    as two values.
442    If with-scrollbars nil, omit the scroller."
443      (let* ((extended-pane
444              (make-pane 'extended-pane
445                         :width 900 :height 400
446                         :name 'window
447                         :end-of-line-action :scroll
448                         :incremental-redisplay t
449                         :background *bg-color*
450                         :foreground *fg-color*
451                         :display-function 'display-window
452                         :command-table 'global-climacs-table))
453             (vbox
454              (vertically ()
455                (if with-scrollbars
456                    (scrolling ()
457                      extended-pane)
458                    extended-pane)
459                (make-pane 'climacs-info-pane
460                           :background *info-bg-color*
461                           :foreground *info-fg-color*
462                           :master-pane extended-pane
463                           :width 900))))
464        (values vbox extended-pane)))
465    
466    (defun split-window (&optional (vertically-p nil) (pane (current-window)))
467      (with-look-and-feel-realization
468          ((frame-manager *application-frame*) *application-frame*)
469        (multiple-value-bind (vbox new-pane) (make-pane-constellation)
470          (let* ((current-window pane)
471                 (constellation-root (find-parent current-window)))
472            (setf (offset (point (buffer current-window))) (offset (point current-window))
473                  (buffer new-pane) (buffer current-window)
474                  (auto-fill-mode new-pane) (auto-fill-mode current-window)
475                  (auto-fill-column new-pane) (auto-fill-column current-window))
476            (push new-pane (windows *application-frame*))
477            (setf *standard-output* new-pane)
478            (replace-constellation constellation-root vbox vertically-p)
479            (full-redisplay current-window)
480            (full-redisplay new-pane)
481            new-pane))))
482    
483    (defun make-typeout-constellation (&optional label)
484      (let* ((typeout-pane
485              (make-pane 'typeout-pane :foreground *fg-color* :background *bg-color*
486                         :width 900 :height 400 :display-time nil))
487             (label
488              (make-pane 'label-pane :label label))
489             (vbox
490              (vertically ()
491                (scrolling (:scroll-bar :vertical) typeout-pane) label)))
492        (values vbox typeout-pane)))
493    
494    (defun typeout-window (&optional (label "Typeout") (pane (current-window)))
495      (with-look-and-feel-realization
496          ((frame-manager *application-frame*) *application-frame*)
497        (multiple-value-bind (vbox new-pane) (make-typeout-constellation label)
498          (let* ((current-window pane)
499                 (constellation-root (find-parent current-window)))
500            (push new-pane (windows *application-frame*))
501            (other-window)
502            (replace-constellation constellation-root vbox t)
503            (full-redisplay current-window)
504            new-pane))))
505    
506    (defun delete-window (&optional (window (current-window)))
507      (unless (null (cdr (windows *application-frame*)))
508        (let* ((constellation (find-parent window))
509               (box (sheet-parent constellation))
510               (box-children (sheet-children box))
511               (other (if (eq constellation (first box-children))
512                          (third box-children)
513                          (first box-children)))
514               (parent (sheet-parent box))
515               (children (sheet-children parent))
516               (first (first children))
517               (second (second children))
518               (third (third children)))
519          (setf (windows *application-frame*)
520                (remove window (windows *application-frame*)))
521          (setf *standard-output* (car (windows *application-frame*)))
522          (sheet-disown-child box other)
523          (sheet-adopt-child parent other)
524          (sheet-disown-child parent box)
525          (reorder-sheets parent (if (eq box first)
526                                     (if third
527                                         (list other second third)
528                                         (list other second))
529                                     (if third
530                                         (list first second other)
531                                         (list first other)))))))
532    
533  (defun make-buffer (&optional name)  (defun make-buffer (&optional name)
534    (let ((buffer (make-instance 'climacs-buffer)))    (let ((buffer (make-instance 'climacs-buffer)))
# Line 389  Signals and error if the file does not e Line 536  Signals and error if the file does not e
536      (push buffer (buffers *application-frame*))      (push buffer (buffers *application-frame*))
537      buffer))      buffer))
538    
539    (defun other-window (&optional pane)
540      (if (and pane (find pane (windows *application-frame*)))
541          (setf (windows *application-frame*)
542                (append (list pane)
543                        (remove pane (windows *application-frame*))))
544          (setf (windows *application-frame*)
545                (append (cdr (windows *application-frame*))
546                        (list (car (windows *application-frame*))))))
547      ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge.
548      (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*))))
549               (> (length (windows *application-frame*)) 1))
550          (other-window)
551          (setf *standard-output* (car (windows *application-frame*)))))
552    
553  (defgeneric erase-buffer (buffer))  (defgeneric erase-buffer (buffer))
554    
555  (defmethod erase-buffer ((buffer string))  (defmethod erase-buffer ((buffer string))

Legend:
Removed from v.1.223  
changed lines
  Added in v.1.224

  ViewVC Help
Powered by ViewVC 1.1.5