lisp/liece-window.el

   1 ;;; liece-window.el --- Window configuration style utility.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-01-08
   6 ;; Revised: 1999-07-05
   7 ;; Keywords: window, window configuration
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'liece-misc)
  33 (require 'liece-intl)
  34
  35 (require 'calist)
  36 (eval-when-compile (require 'cl))
  37
  38 (defgroup liece-window nil
  39   "Window configuration"
  40   :tag "Window configuration"
  41   :group 'liece)
  42
  43 (defcustom liece-window-min-width 2
  44   "Minimal width of liece window."
  45   :type 'integer
  46   :group 'liece-window)
  47
  48 (defcustom liece-window-min-height 2
  49   "Minimal height of liece window."
  50   :type 'integer
  51   :group 'liece-window)
  52
  53 (defcustom liece-window-style-directory nil
  54   "Normal position of style configuration files."
  55   :type 'directory
  56   :group 'liece-window)
  57
  58 (defcustom liece-window-default-style "bottom"
  59   "Default style."
  60   :type 'string
  61   :group 'liece-window)
  62
  63 (defcustom liece-window-to-buffer
  64   '((channel . liece-channel-buffer)
  65     (others . liece-others-buffer)
  66     (dialogue . liece-dialogue-buffer)
  67     (command . liece-command-buffer)
  68     (channel-list . liece-channel-list-buffer)
  69     (nick . liece-nick-buffer))
  70   "Window abbreviation to buffer alist."
  71   :type '(repeat
  72           (cons (symbol :tag "Abbrev")
  73                 (symbol :tag "Buffer")))
  74   :group 'liece-window)
  75
  76 (defconst liece-window-split-types '(horizontal vertical))
  77
  78 (defvar liece-window-style-configuration-alist nil)
  79 (defvar liece-window-current-style nil)
  80 (defvar liece-window-configuration-stack nil)
  81
  82 (defun liece-window-field-match-method-as-default-rule
  83   (calist field-type field-value)
  84   (let* ((field (assq field-type calist)) (value (cdr field)))
  85     (cond ((null field)
  86            (cons (cons field-type field-value) calist))
  87           ((and (symbolp field-value) (eq field-value 'any))
  88            calist)
  89           ((and (symbolp value) (eq field-value value))
  90            calist))))
  91
  92 (define-calist-field-match-method
  93   'command-buffer-mode
  94   'liece-window-field-match-method-as-default-rule)
  95
  96 (define-calist-field-match-method
  97   'channel-buffer-mode
  98   'liece-window-field-match-method-as-default-rule)
  99
 100 (define-calist-field-match-method
 101   'nick-buffer-mode
 102   'liece-window-field-match-method-as-default-rule)
 103
 104 (define-calist-field-match-method
 105   'channel-list-buffer-mode
 106   'liece-window-field-match-method-as-default-rule)
 107
 108 (defmacro liece-window-add-style (&rest calist)
 109   `(ctree-set-calist-strictly 'liece-window-style-configuration-alist
 110                               ',calist))
 111
 112 (defmacro liece-window-define-reconfiguration-predicate (name &rest body)
 113   `(defun-maybe ,name ,@body))
 114
 115 (put 'liece-window-define-reconfiguration-predicate
 116      'lisp-indent-function 'defun)
 117
 118 (defmacro liece-window-set-default-style ()
 119   "Set window configuration with fallback style."
 120   '(liece-window-add-style
 121     (command-buffer-mode . any)
 122     (channel-buffer-mode . any)
 123     (nick-buffer-mode . any)
 124     (channel-list-buffer-mode . any)
 125     (configuration
 126      (vertical
 127       1.0
 128       (dialogue 1.0)
 129       (command 4 point)))))
 130
 131 (defsubst liece-window-load-style-file (style)
 132   "Load style file."
 133   (condition-case nil
 134       (progn
 135         (if (null liece-window-style-directory)
 136             (setq liece-window-style-directory
 137                   (liece-locate-path "styles")))
 138         (setq liece-window-style-configuration-alist nil)
 139         (load (expand-file-name style liece-window-style-directory))
 140         (setq liece-window-current-style style))
 141     (error
 142      (liece-message "Style file load failed.")
 143      (liece-window-set-default-style))))
 144
 145 (defmacro liece-window-percent-to-rate (percent)
 146   `(/ ,percent 100.0))
 147
 148 (defmacro liece-window-to-buffer-helper (window)
 149   `(cond ((symbolp ,window)
 150           (symbol-value ,window))
 151          (t ,window)))
 152
 153 (defmacro liece-window-safe-select-window (window)
 154   `(if ,window (select-window ,window)))
 155
 156 ;;;###liece-autoload
 157 (defun liece-command-set-window-style (style)
 158   (interactive
 159    (let ((styles (directory-files liece-window-style-directory)))
 160      (list
 161       (liece-minibuffer-completing-read
 162        "Window style: " (list-to-alist styles) nil t nil nil
 163        liece-window-current-style))))
 164   (liece-window-load-style-file style))
 165
 166 (defun liece-command-reload-window-style ()
 167   (interactive)
 168   (liece-window-load-style-file
 169    (or liece-window-current-style
 170        liece-window-default-style)))
 171
 172 (defmacro liece-window-default-reconfiguration-predicate ()
 173   '(or (one-window-p t)
 174        (null (liece-get-buffer-window liece-command-buffer))
 175        (and (not liece-channel-buffer-mode)
 176             (null (liece-get-buffer-window liece-dialogue-buffer)))
 177        (and liece-channel-buffer-mode
 178             (null (liece-get-buffer-window liece-channel-buffer))
 179             (null (liece-get-buffer-window liece-others-buffer)))
 180        (and liece-channel-buffer-mode
 181             (if liece-nick-buffer-mode
 182                 (null (liece-get-buffer-window liece-nick-buffer))
 183               (not (null (liece-get-buffer-window liece-nick-buffer)))))
 184        (if liece-channel-list-buffer-mode
 185            (null (liece-get-buffer-window liece-channel-list-buffer))
 186          (not (null (liece-get-buffer-window liece-channel-list-buffer))))))
 187
 188 ;;;###liece-autoload
 189 (defun liece-configure-windows ()
 190   (let ((liece-nick-buffer-mode liece-nick-buffer-mode)
 191         (liece-channel-buffer-mode liece-channel-buffer-mode)
 192         situation calist split predicate)
 193     (if (and (get 'liece-nick-buffer-mode 'hide)
 194              liece-nick-window-auto-hide)
 195         (setq liece-nick-buffer-mode nil))
 196     (if (not (liece-channel-last
 197               (if (eq liece-command-buffer-mode 'chat)
 198                   liece-current-chat-partners
 199                 liece-current-channels)))
 200         (setq liece-channel-buffer-mode nil))
 201     (setq situation
 202           `((channel-buffer-mode . ,liece-channel-buffer-mode)
 203             (nick-buffer-mode . ,liece-nick-buffer-mode)
 204             (channel-list-buffer-mode . ,liece-channel-list-buffer-mode)
 205             (command-buffer-mode . ,liece-command-buffer-mode)))
 206     (or liece-window-current-style
 207         (liece-command-set-window-style liece-window-default-style))
 208     (setq calist (ctree-match-calist liece-window-style-configuration-alist
 209                                      situation)
 210           split (cadr (assq 'configuration calist))
 211           predicate (cdr (assq 'reconfiguration-predicate calist)))
 212     (when (and split
 213                (or (null predicate)
 214                    (and predicate
 215                         (liece-functionp predicate)
 216                         (funcall predicate))))
 217       (setq truncate-partial-width-windows
 218             (not liece-truncate-partial-width-windows))
 219       (if liece-use-full-window (delete-other-windows))
 220       (save-excursion
 221         (switch-to-buffer liece-command-buffer) ;; u-mu.
 222         (liece-window-configure-frame split)))))
 223
 224 (defun liece-window-configure-frame (split &optional window)
 225   (or window
 226       (setq window (get-buffer-window (current-buffer))))
 227   (liece-window-safe-select-window window)
 228   (while (and (not (assq (car split) liece-window-to-buffer))
 229               (liece-functionp (car split)))
 230     (setq split (eval split)))
 231   (let* ((type (car split))
 232          (subs (cddr split))
 233          (len (if (eq type 'horizontal) (window-width) (window-height)))
 234          (total 0)
 235          (window-min-width
 236           (or liece-window-min-width window-min-width))
 237          (window-min-height
 238           (or liece-window-min-height window-min-height))
 239          s result new-win rest comp-subs size sub)
 240     (cond
 241      ;; Nothing to do here.
 242      ((null split))
 243      ;; Don't switch buffers.
 244      ((null type)
 245       (and (memq 'point split) window))
 246      ;; This is a buffer to be selected.
 247      ((not (memq type '(horizontal vertical)))
 248       (let ((buffer (cond ((stringp type) type)
 249                           (t (cdr (assq type liece-window-to-buffer))))))
 250         (unless buffer
 251           (error "Illegal buffer type: %s" type))
 252         (switch-to-buffer
 253          (liece-window-to-buffer-helper buffer))
 254         ;; We return the window if it has the `point' spec.
 255         (and (memq 'point split) window)))
 256      (t
 257       (when (> (length subs) 0)
 258         ;; First we have to compute the sizes of all new windows.
 259         (while subs
 260           (setq sub (append (pop subs) nil))
 261           (while (and (not (assq (car sub) liece-window-to-buffer))
 262                       (liece-functionp (car sub)))
 263             (setq sub (eval sub)))
 264           (when sub
 265             (push sub comp-subs)
 266             (setq size (cadar comp-subs))
 267             (cond ((equal size 1.0)
 268                    (setq rest (car comp-subs))
 269                    (setq s 0))
 270                   ((floatp size)
 271                    (setq s (floor (* size len))))
 272                   ((integerp size)
 273                    (setq s size))
 274                   ((symbolp size)
 275                    (setq s
 276                          (floor
 277                           (* (liece-window-percent-to-rate
 278                               (symbol-value size))
 279                              len))))
 280                   (t
 281                    (error "Illegal size: %s" size)))
 282             ;; Try to make sure that we are inside the safe limits.
 283             (cond ((zerop s))
 284                   ((eq type 'horizontal)
 285                    (setq s (max s window-min-width)))
 286                   ((eq type 'vertical)
 287                    (setq s (max s window-min-height))))
 288             (setcar (cdar comp-subs) s)
 289             (incf total s)))
 290         ;; Take care of the "1.0" spec.
 291         (if rest
 292             (setcar (cdr rest) (- len total))
 293           (error "No 1.0 specs in %s" split))
 294         ;; The we do the actual splitting in a nice recursive
 295         ;; fashion.
 296         (setq comp-subs (nreverse comp-subs))
 297         (while comp-subs
 298           (if (null (cdr comp-subs))
 299               (setq new-win window)
 300             (setq new-win
 301                   (split-window window (cadar comp-subs)
 302                                 (eq type 'horizontal))))
 303           (setq result (or (liece-window-configure-frame
 304                             (car comp-subs) window)
 305                            result))
 306           (liece-window-safe-select-window new-win)
 307           (setq window new-win)
 308           (setq comp-subs (cdr comp-subs))))
 309       ;; Return the proper window, if any.
 310       (liece-window-safe-select-window result)))))
 311
 312 (defun liece-window-configuration-push ()
 313   (let ((frame (selected-frame))
 314         (config (current-window-configuration)))
 315     (push (list frame config)
 316           liece-window-configuration-stack)))
 317
 318 (defun liece-window-configuration-pop ()
 319   (let* ((frame (selected-frame))
 320          (triple (assq frame liece-window-configuration-stack)))
 321     (when (and triple (window-configuration-p (cadr triple)))
 322       (set-window-configuration (cadr triple))
 323       (if (setq frame (assq frame liece-window-configuration-stack))
 324           (setq liece-window-configuration-stack
 325                 (delq frame liece-window-configuration-stack))))
 326     liece-window-configuration-stack))
 327
 328 (provide 'liece-window)
 329
 330 ;;; liece-window.el ends here