gui.lisp 27.1 KB
Newer Older
1 2
;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-

3
;;;  (c) copyright 2004-2005 by
4
;;;           Robert Strandh (strandh@labri.fr)
5
;;;  (c) copyright 2004-2005 by
6
;;;           Elliott Johnson (ejohnson@fasl.info)
7 8
;;;  (c) copyright 2005 by
;;;           Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 10
;;;  (c) copyright 2005 by
;;;           Aleksandar Bakic (a_bakic@yahoo.com)
11 12
;;;  (c) copyright 2006-2008 by
;;;           Troels Henriksen (athas@sigkill.dk)
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; GUI for the Climacs editor. 

(in-package :climacs-gui)

33 34 35 36 37 38 39 40 41 42 43 44
(defvar *default-external-format* :utf-8
  "The encoding to use by default when reading and saving
files.")

(defvar *with-scrollbars* t
  "If T, classic look and feel. If NIL, stripped-down look (:")

(defvar *show-info-pane-mark-position* nil
  "If T, show the line number and column number in the info pane
  of all panes. If NIL, don't. This is off by default, as finding
  the line and column numbers is potentially expensive.")

45 46
(defvar *climacs-target-creator* nil
  "A function for creating targets for commands potentially
47
acting over multiple views.")
48

49
(defvar *climacs-text-style* (make-text-style :fix nil nil)
50 51
  "The default CLIM text style used in Climacs panes.")

52 53 54 55 56 57 58 59 60
(defclass climacs-buffer (drei-buffer)
  ((%external-format :initform *default-external-format*
                     :accessor external-format
                     :documentation "The external format that was
used when reading the source destination of the buffer
contents.")))

(defclass climacs-pane (drei-pane esa-pane-mixin)
  ()
61
  (:metaclass modual-class)
62
  (:default-initargs
63 64
   :view (make-instance 'textual-drei-syntax-view
          :buffer (make-instance 'climacs-buffer))
65
   :display-time :command-loop
66
   :text-style *climacs-text-style*
67 68
   :width 900 :height 400))

69 70 71
(defmethod command-table ((pane climacs-pane))
  (command-table (pane-frame pane)))

72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
(define-condition view-setting-error (error)
  ((%view :accessor view
          :initarg :view
          :initform (error "The view used in the error-causing operation must be supplied")
          :documentation "The view that is attempted set"))
  (:documentation "This error is signalled when something goes
wrong while setting the view of a Climacs pane."))

(define-condition unknown-view (view-setting-error)
  ()
  (:report (lambda (condition stream)
             (format
              stream "Attempting to set view of a window to view object ~A, which is not known to Climacs"
              (view condition))))
  (:documentation "This error is signalled whenever a window is
attempted to be set to a view that is not recognized by the
Climacs instance the window belongs to."))

(define-condition view-already-displayed (view-setting-error)
  ((%window :accessor window
            :initarg :window
            :initform (error "The window already displaying the view must be provided")
            :documentation "The window that already displays the view"))
  (:report (lambda (condition stream)
             (format
              stream "Attempting to set view of a window to view object ~A, which is already on display in another window"
              (view condition))))
  (:documentation "This error is signalled whenever a window is
attempted to be set to a view already on display in some other
window"))

(defmethod (setf view) :around ((view drei-view) (pane climacs-pane))
  (let ((window-displaying-view
         (find-if #'(lambda (other-pane)
                      (and (not (eq other-pane pane))
107
                           (typep other-pane 'climacs-pane)
108
                           (eq (view other-pane) view)))
109 110
                  (windows (pane-frame pane))))
        (old-view-active (active (view pane))))
111 112 113 114 115 116 117 118 119 120
    (prog1
        (cond ((not (member view (views (pane-frame pane))))
               (restart-case (error 'unknown-view :view view)
                 (add-to-view-list ()
                  :report "Add the view object to Climacs"
                  (push view (views (pane-frame pane)))
                  (setf (view pane) view))))
              (window-displaying-view
               (restart-case
                   (error 'view-already-displayed :view view :window window-displaying-view)
121 122 123 124
                 (switch-to-pane ()
                  :report "Switch the active window to the one containing the view"
                  (other-window window-displaying-view)
                  view)
125 126 127 128 129 130 131 132 133 134 135 136 137
                 (remove-other-use ()
                  :report "Make the other window try to display some other view"
                  (setf (view window-displaying-view) (any-preferably-undisplayed-view))
                  (setf (view pane) view))
                 (remove-other-pane ()
                  :report "Remove the other window displaying the view"
                  (delete-window window-displaying-view)
                  (setf (view pane) view))
                 (clone-view ()
                  :report "Make a clone of the view and use that instead"
                  (setf (view pane) (clone-view-for-climacs
                                     (pane-frame window-displaying-view) view)))
                 (cancel ()
138
                  :report "Cancel the setting of the windows view and just return nil")))
139
              (t (call-next-method)))
140 141 142 143 144
      ;; Move view to the front of the view-list, doesn't carry
      ;; semantic significance, but makes view-switching more
      ;; convenient.
      (setf (views (pane-frame pane))
            (cons view (delete view (views (pane-frame pane)))))
145 146
      (when old-view-active
        (ensure-only-view-active (pane-frame pane) view)))))
147 148 149

(defmethod (setf view) :before ((view drei-view) (pane climacs-pane))
  (with-accessors ((views views)) (pane-frame pane)
150 151
    (full-redisplay pane)))

152 153 154 155 156 157 158
(defgeneric buffer-pane-p (pane)
  (:documentation "Returns T when a pane contains a buffer."))

(defmethod buffer-pane-p (pane)
  (declare (ignore pane))
  nil)

159
(defmethod buffer-pane-p ((pane climacs-pane))
160
  (typep (view pane) 'drei-buffer-view))
161

162 163 164 165 166 167 168 169
(defmethod in-focus-p ((pane climacs-pane))
  (eq pane (first (windows *application-frame*))))

(defvar *info-bg-color* +gray85+)
(defvar *info-fg-color* +black+)
(defvar *mini-bg-color* +white+)
(defvar *mini-fg-color* +black+)

170 171 172 173 174
(defclass climacs-info-pane (info-pane)
  ()
  (:default-initargs
      :height 20 :max-height 20 :min-height 20
      :display-function 'display-info
175 176 177 178
      :incremental-redisplay t
      :background *info-bg-color*
      :foreground *info-fg-color*
      :width 900))
179 180 181 182

(defclass climacs-minibuffer-pane (minibuffer-pane)
  ()
  (:default-initargs
183
   :default-view +textual-view+
184 185 186
   :background *mini-bg-color*
   :foreground *mini-fg-color*
   :width 900))
187

188 189 190
;;; Basic command tables follow. The global command table,
;;; `global-climacs-table', inherits from these, so they should not
;;; contain any overly syntax-specific commands. The idea is that it
191 192 193 194 195 196 197
;;; should always be safe to invoke commands from these tables,
;;; without risking adding alien commands that require the current
;;; window to contain a specific type of view or syntax. In general,
;;; the Climacs frame has a special command table of type
;;; `climacs-command-table' (that's not its name) that selectively
;;; inherits from view-specific tables and the `global-climacs-table'
;;; based on the current window and view.
198

199
;;; Basic functionality
200
(make-command-table 'base-table :errorp nil)
201
;;; Buffers
202
(make-command-table 'buffer-table :errorp nil)
203
;;; Commands used for climacs development
204
(make-command-table 'development-table :errorp nil)
205
;;; Windows
206
(make-command-table 'window-table :errorp nil)
207

208 209 210 211 212 213 214
;;; customization of help.  FIXME: this might be better done by having
;;; the functions that the ESA commands call be customizeable generic
;;; functions; however, while they're not, scribbling over the ESA
;;; command tables is a bad thing.
(make-command-table 'climacs-help-table :inherit-from '(help-table)
                    :errorp nil)

215 216 217
(make-command-table 'global-climacs-table
                    :errorp nil
                    :inherit-from '(base-table
218
                                    buffer-table
219 220 221 222 223 224
                                    window-table
                                    development-table
                                    climacs-help-table
                                    global-esa-table
                                    esa-io-table))

Troels Henriksen's avatar
Troels Henriksen committed
225 226
;; This command table is what assembles the various other command
;; tables for the commands actually accessible by the user.
227 228
(defclass climacs-command-table (standard-command-table)
  ())
229

230
(defmethod command-table-inherit-from ((table climacs-command-table))
Troels Henriksen's avatar
Troels Henriksen committed
231
  (append (view-command-tables (current-view))
232
          '(global-climacs-table)
Troels Henriksen's avatar
Troels Henriksen committed
233
          (when (use-editor-commands-p (current-view))
234
            '(editor-table))
235 236
          (call-next-method)))

Troels Henriksen's avatar
Troels Henriksen committed
237 238 239 240
;; This is the actual command table that will be used for Climacs.
(make-command-table 'climacs-global-table
 :inherit-from (list (make-instance 'climacs-command-table
                      :name 'climacs-dispatching-table))
241 242 243 244
 :menu `(("File" :menu esa-io-menu-table)
         ("Macros" :menu keyboard-macro-menu-table)
         ("Windows" :menu window-menu-table)
         ("Help" :menu help-menu-table))
Troels Henriksen's avatar
Troels Henriksen committed
245 246
 :errorp nil)

247 248
(define-application-frame climacs (esa-frame-mixin
				   standard-application-frame)
249
  ((%views :initform '() :accessor views)
250 251
   (%groups :initform (make-hash-table :test #'equal) :accessor groups)
   (%active-group :initform nil :accessor active-group)
Troels Henriksen's avatar
Troels Henriksen committed
252
   (%command-table :initform (find-command-table 'climacs-global-table)
253
                   :accessor find-applicable-command-table
254 255 256 257
                   :accessor frame-command-table)
   (%output-stream :accessor output-stream
                   :initform nil
                   :initarg :output-stream))
Troels Henriksen's avatar
Troels Henriksen committed
258
  (:menu-bar climacs-global-table)
259
  (:panes
260
   (climacs-window
261 262
    (let* ((*esa-instance* *application-frame*)
           (climacs-pane (make-pane 'climacs-pane :active t))
263
	   (info-pane (make-pane 'climacs-info-pane
264 265 266 267
                       :master-pane climacs-pane)))
      (unless (output-stream *esa-instance*)
        (setf (output-stream *esa-instance*)
              (make-typeout-stream *application-frame* "*standard-output*")))
268
      (setf (windows *application-frame*) (list climacs-pane)
269
	    (views *application-frame*) (list (view climacs-pane)))
270
      (vertically ()
271 272 273 274 275
        (if *with-scrollbars*
            (scrolling ()
              climacs-pane)
            climacs-pane)
        info-pane)))
276
   (minibuffer (make-pane 'climacs-minibuffer-pane)))
277 278
  (:layouts
   (default
279
       (overlaying ()
280
         (vertically ()
281 282
           climacs-window
           minibuffer))))
283
  (:top-level ((lambda (frame)
284 285
                 (with-frame-manager ((make-instance 'climacs-frame-manager))
                   (esa-top-level frame :prompt "M-x "))))))
286

287 288 289 290
(define-esa-top-level ((frame climacs) command-parser
                       command-unparser
                       partial-command-parser
                       prompt)
291
 :bindings ((*default-target-creator* *climacs-target-creator*)
292
            (*previous-command* (previous-command (drei-instance)))
293 294
            (*standard-output* (or (output-stream frame)
                                   *terminal-io*))))
295

296 297 298
(defmethod frame-standard-input ((frame climacs))
  (get-frame-pane frame 'minibuffer))

299 300 301 302 303 304
(defmethod buffers ((climacs climacs))
  (remove-duplicates
   (mapcar #'buffer (remove-if-not
                     #'(lambda (view)
                         (typep view 'drei-buffer-view))
                     (views climacs)))))
305

306
(defmethod esa-current-buffer ((application-frame climacs))
307 308
  (when (buffer-pane-p (esa-current-window application-frame))
    (buffer (current-view (esa-current-window application-frame)))))
309 310 311 312 313 314

(defmethod (setf esa-current-buffer) ((new-buffer climacs-buffer)
                                      (application-frame climacs))
  (setf (buffer (current-view (esa-current-window application-frame)))
        new-buffer))

315 316 317
(defmethod drei-instance-of ((frame climacs))
  (esa-current-window frame))

318 319 320 321 322 323 324 325 326 327
(defmethod (setf windows) :after (new-val (climacs climacs))
  ;; Ensures that we don't end up with two views that both believe
  ;; they are active.
  (activate-window (esa-current-window climacs)))

(defun current-window-p (window)
  "Return true if `window' is the current window of its Climacs
instance."
  (eq window (esa-current-window (pane-frame window))))

328
(defun ensure-only-view-active (climacs &optional view)
329
  "Ensure that `view' is the only view of `climacs' that is
330
active. `View' may be NIL, in which case no view is set as
331 332 333 334
active."
  (dolist (other-view (views climacs))
    (unless (eq other-view view)
      (setf (active other-view) nil)))
335 336
  (unless (null view)
    (setf (active view) t)))
337

338 339 340
(defmethod (setf views) :around (new-value (frame climacs))
  ;; If any windows show a view that no longer exists in the
  ;; view-list, make them show something else. The view-list might be
341 342
  ;; destructively updated, so copy it for safekeeping. Also make sure
  ;; only one view thinks that it's active.
343 344 345 346 347
  (with-accessors ((views views)) frame
    (let* ((old-views (copy-list views))
           (removed-views (set-difference
                           old-views (call-next-method) :test #'eq)))
      (dolist (window (windows frame))
348 349
        (when (and (typep window 'climacs-pane)
                   (member (view window) removed-views :test #'eq))
350 351 352
          (handler-case (setf (view window)
                              (any-preferably-undisplayed-view))
            (view-already-displayed ()
353 354 355 356
              (delete-window window)))))))
  (ensure-only-view-active
   frame (when (typep (esa-current-window frame) 'climacs-pane)
           (view (esa-current-window frame)))))
357 358 359 360 361 362 363

(defmethod (setf views) :after ((new-value null) (frame climacs))
  ;; You think you can remove all views? I laught at your silly
  ;; attempt!
  (setf (views frame) (list (make-new-view-for-climacs
                             frame 'textual-drei-syntax-view))))

364 365 366
(defmethod command-for-unbound-gestures ((frame climacs) gestures)
  (command-for-unbound-gestures (esa-current-window frame) gestures))

367 368 369 370 371 372 373 374 375 376 377
(defun make-view-subscript-generator (climacs)
  #'(lambda (name)
      (1+ (reduce #'max (remove name (views climacs)
                         :test-not #'string= :key #'name)
           :initial-value 0
           :key #'subscript))))

(defun clone-view-for-climacs (climacs view &rest initargs)
  "Clone `view' and add it to `climacs's list of views."
  (let ((new-view (apply #'clone-view view
                   :subscript-generator (make-view-subscript-generator climacs)
378 379
                   :active nil initargs)))
    (setf (syntax new-view) (make-syntax-for-view new-view (class-of (syntax view))))
380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397
    (push new-view (views climacs))
    new-view))

(defun make-new-view-for-climacs (climacs view-class &rest initargs)
  "Instiantiate an object of type `view-class' and add it to
`climacs's list of views."
  (let ((new-view (apply #'make-instance view-class
                   :subscript-generator (make-view-subscript-generator climacs)
                   initargs)))
    (push new-view (views climacs))
    new-view))

(defun any-view ()
  "Return some view, any view."
  (first (views *esa-instance*)))

(defun any-displayed-view ()
  "Return some view on display."
398
  (view (esa-current-window *application-frame*)))
399

400 401 402 403 404 405 406 407
(defun view-on-display (climacs view)
  "Return true if `view' is on display in a window of `climacs',
false otherwise."
  (member view (remove-if-not #'(lambda (window)
                                  (typep window 'climacs-pane))
                              (windows climacs))
   :key #'view))

408 409 410
(defun any-preferably-undisplayed-view ()
  "Return some view, any view, preferable one that is not
currently displayed in any window."
411
  (or (find-if-not #'(lambda (view)
412
                       (view-on-display *esa-instance* view))
413
                   (views *esa-instance*))
414 415 416 417 418
      (any-view)))

(defun any-undisplayed-view ()
  "Return some view, any view, as long as it is not currently
displayed in any window. If necessary, clone a view on display."
419 420 421
  (or (find-if-not #'(lambda (view)
                       (view-on-display *esa-instance* view))
                   (views *esa-instance*))
422
      (clone-view-for-climacs *esa-instance* (any-view))))
423

424 425 426 427 428 429 430 431 432
(define-presentation-type read-only ())
(define-presentation-method highlight-presentation 
    ((type read-only) record stream state)
  nil)
(define-presentation-type modified ())
(define-presentation-method highlight-presentation 
    ((type modified) record stream state)
  nil)

433 434 435 436
(defgeneric display-view-info-to-info-pane (info-pane master-pane view)
  (:documentation "Display interesting information about
`view' (which is in `master-pane') to `info-pane'."))

437 438 439 440 441 442
(defgeneric display-view-status-to-info-pane (info-pane master-pane view)
  (:documentation "Display interesting information about the
status of `view' (which is in `master-pane') to `info-pane'. The
status should be things like whether it is modified, read-only,
etc."))

443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481
(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane)
                                           (master-pane climacs-pane)
                                           (view drei-syntax-view))
  (with-text-family (info-pane :sans-serif)
    (display-syntax-name (syntax view) info-pane :view view)))

(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane)
                                           (master-pane climacs-pane)
                                           (view textual-drei-syntax-view))
  (let ((point (point view))
        (bot (bot view))
        (top (top view))
        (size (size (buffer view))))
    (format info-pane "  ~A  "
	    (cond ((and (mark= size bot)
			(mark= 0 top))
		   "")
		  ((mark= size bot)
		   "Bot")
		  ((mark= 0 top)
		   "Top")
		  (t (format nil "~a%"
			     (round (* 100 (/ (offset top)
					      size)))))))
    (when *show-info-pane-mark-position*
      (format info-pane "(~A,~A)     "
              (1+ (line-number point))
              (column-number point)))
    (princ #\( info-pane)
    (call-next-method)
    (format info-pane "~{~:[~*~; ~A~]~}" (list
                                          (overwrite-mode view)
                                          "Ovwrt"
                                          (auto-fill-mode view)
                                          "Fill"
                                          (isearch-mode master-pane)
                                          "Isearch"))
    (princ #\) info-pane)))

482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane)
                                           (master-pane climacs-pane)
                                           (view typeout-view)))

(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane)
                                             (master-pane climacs-pane)
                                             (view drei-syntax-view))
  (with-output-as-presentation (info-pane view 'read-only)
    (princ (cond
             ((read-only-p (buffer view)) "%")
             ((needs-saving (buffer view)) "*")
             (t "-"))
           info-pane))
  (with-output-as-presentation (info-pane view 'modified)
    (princ (cond
             ((needs-saving (buffer view)) "*")
             ((read-only-p (buffer view)) "%")
             (t "-"))
           info-pane))
  (princ "  " info-pane))

(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane)
                                             (master-pane climacs-pane)
                                             (view typeout-view)))

507
(defun display-info (frame pane)
508
  (let* ((master-pane (master-pane pane))
509
	 (view (view master-pane)))
510
    (princ "   " pane)
511
    (display-view-status-to-info-pane pane master-pane view)
512
    (with-text-face (pane :bold)
513 514
      (with-output-as-presentation (pane view 'view)
        (format pane "~A" (subscripted-name view)))
515
      ;; FIXME: bare 25.
516
      (format pane "~V@T" (max (- 25 (length (subscripted-name view))) 1)))
517
    (display-view-info-to-info-pane pane master-pane view)
518
    (with-text-family (pane :sans-serif)
519
      (princ (if (recordingp frame)
520 521 522
		 "Def"
		 "")
	     pane))))
523

524 525
(defmethod handle-drei-condition ((drei climacs-pane) condition)
  (call-next-method)
526
  (display-drei drei :redisplay-minibuffer t))
527

528
(defmethod execute-frame-command :around ((frame climacs) command)
529 530 531 532 533
  (if (eq frame *esa-instance*)
      (handling-drei-conditions
        (with-undo ((buffers frame))
          (call-next-method)))
      (call-next-method)))
534

535
(define-command (com-full-redisplay :name t :command-table base-table) ()
536 537
  "Redisplay the contents of the current window.
FIXME: does this really have that effect?"
538
  (full-redisplay (current-window)))
539

540 541 542
(set-key 'com-full-redisplay
	 'base-table
	 '((#\l :control)))
543

544 545 546 547
(defun activate-window (window)
  "Set `window' to be the active window for its Climacs
instance. `Window' must already be recognized by the Climacs
instance."
548
  ;; Ensure that only one pane can be active.
549 550 551 552 553 554 555 556
  (let ((climacs (pane-frame window)))
    (unless (current-window-p window)
      (when (typep (esa-current-window climacs) 'climacs-pane)
        (setf (active (esa-current-window climacs)) nil))
      (unless (member window (windows climacs))
        (error "Cannot set unknown window to be active window"))
      (setf (windows climacs)
            (cons window (remove window (windows climacs)))))
557 558 559
    (ensure-only-view-active
     climacs (when (typep window 'climacs-pane)
               (view window)))))
560

561 562
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
563
;;; Pane functions
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615

(defun replace-constellation (constellation additional-constellation vertical-p)
  (let* ((parent (sheet-parent constellation))
	 (children (sheet-children parent))
	 (first (first children))
	 (second (second children))
	 (third (third children))
	 (first-split-p (= (length (sheet-children parent)) 2))
	 (parent-region (sheet-region parent))
	 (parent-height (rectangle-height parent-region))
	 (parent-width (rectangle-width parent-region))
	 (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing.
         (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget)))
    (assert (member constellation children))
    
    (when first-split-p (setf (sheet-region filler) (sheet-region parent)) 
      (sheet-adopt-child parent filler))

    (sheet-disown-child parent constellation)

    (if vertical-p
	(resize-sheet constellation parent-width (/ parent-height 2))
	(resize-sheet constellation  (/ parent-width 2) parent-height))
    
    (let ((new (if vertical-p
		   (vertically ()
		     constellation adjust additional-constellation)
		   (horizontally ()
		     constellation adjust additional-constellation))))
      (sheet-adopt-child parent new)

      (when first-split-p (sheet-disown-child parent filler))
      (reorder-sheets parent 
		      (if (eq constellation first)
			  (if third
			      (list new second third)
			      (list new second))
			  (if third
			      (list first second new)
			      (list first new)))))))
(defun find-parent (sheet)
  (loop for parent = (sheet-parent sheet)
	  then (sheet-parent parent)
	until (typep parent 'vrack-pane)
	finally (return parent)))

(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*))
  "make a vbox containing a scroller pane as its first child and an
info pane as its second child.  The scroller pane contains a viewport
which contains an extended pane.  Return the vbox and the extended pane
as two values.
If with-scrollbars nil, omit the scroller."
616 617
  (let* ((climacs-pane
	  (make-pane 'climacs-pane :name 'window))
618 619 620 621
	 (vbox
	  (vertically ()
	    (if with-scrollbars
		(scrolling ()
622 623
		  climacs-pane)
		climacs-pane)
624
	    (make-pane 'climacs-info-pane
625 626
                       :master-pane climacs-pane))))
    (values vbox climacs-pane)))
627

628
(defgeneric setup-split-pane (orig-pane new-pane clone-view)
629
  (:documentation "Perform split-setup operations `new-pane',
630
which is supposed to be a pane that has been freshly split from
631 632 633 634 635
`orig-pane'. If `clone-view' is true, set the view of the new
pane to a clone of the view in `orig-pane', provided that
`orig-pane' has a view."))

(defmethod setup-split-pane ((orig-pane climacs-pane) (new-pane climacs-pane) clone-view)
636 637
  (when (buffer-view-p (view orig-pane))
    (setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane)))))
638
  (setf (view new-pane) (if clone-view
639
                            (clone-view-for-climacs (pane-frame orig-pane) (view orig-pane))
640 641 642
                            (any-preferably-undisplayed-view))))

(defun split-window (&optional (vertically-p nil) (clone-view nil) (pane (current-window)))
643
  (with-look-and-feel-realization
644
      ((frame-manager *esa-instance*) *esa-instance*)
645 646 647
    (multiple-value-bind (vbox new-pane) (make-pane-constellation)
      (let* ((current-window pane)
	     (constellation-root (find-parent current-window)))
648 649
        (setup-split-pane current-window new-pane clone-view)
	(push new-pane (rest (windows *esa-instance*)))
650 651 652
	(replace-constellation constellation-root vbox vertically-p)
	(full-redisplay current-window)
	(full-redisplay new-pane)
653
        (activate-window pane)
654 655 656
	new-pane))))

(defun delete-window (&optional (window (current-window)))
657
  (unless (null (cdr (windows *esa-instance*)))
658 659 660 661 662 663 664 665 666 667 668
    (let* ((constellation (find-parent window))
	   (box (sheet-parent constellation))
	   (box-children (sheet-children box))
	   (other (if (eq constellation (first box-children))
		      (third box-children)
		      (first box-children)))
	   (parent (sheet-parent box))
	   (children (sheet-children parent))
	   (first (first children))
	   (second (second children))
	   (third (third children)))
669 670
      (setf (windows *esa-instance*)
	    (delete window (windows *esa-instance*)))
671 672 673 674 675 676 677 678 679 680
      (sheet-disown-child box other)
      (sheet-adopt-child parent other)
      (sheet-disown-child parent box)
      (reorder-sheets parent (if (eq box first)
				 (if third
				     (list other second third)
				     (list other second))
				 (if third
				     (list first second other)
				     (list first other)))))))
681

682
(defun other-window (&optional pane)
683 684
  (if (and pane (find pane (windows *esa-instance*)))
      (setf (windows *esa-instance*)
685
            (append (list pane)
686 687 688
                    (remove pane (windows *esa-instance*))))
      (setf (windows *esa-instance*)
            (append (rest (windows *esa-instance*))
689
                    (list (esa-current-window *esa-instance*)))))
690
  (activate-window (esa-current-window *esa-instance*)))
691

692 693
;;; For the ESA help functions.

694
(defmethod invoke-with-help-stream ((frame climacs) title continuation)
695
  (with-typeout-view (stream title t)
696
    (funcall continuation stream)))