code.delx.au - gnu-emacs-elpa/blob - darkroom.el

   1 ;;; darkroom.el --- Remove visual distractions and focus on writing  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014  João Távora
   4
   5 ;; Author: João Távora <joaotavora@gmail.com>
   6 ;; Keywords: convenience, emulations
   7 ;; Package-Requires: ((cl-lib "0.5"))
   8 ;; Version: 0.1
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; The main entrypoints to this extension are two minor modes:
  26 ;;
  27 ;;    M-x darkroom-mode
  28 ;;    M-x darkroom-tentative-mode
  29 ;;
  30 ;; `darkroom-mode' makes visual distractions disappear: the
  31 ;; mode-line is temporarily elided, text is enlarged and margins are
  32 ;; adjusted so that it's centered on the window.
  33 ;;
  34 ;; `darkroom-tentative-mode' is similar, but it doesn't immediately
  35 ;; turn-on `darkroom-mode', unless the current buffer lives in the
  36 ;; sole window of the Emacs frame (i.e. all other windows are
  37 ;; deleted). Whenever the frame is split to display more windows and
  38 ;; more buffers, the buffer exits `darkroom-mode'. Whenever they are
  39 ;; deleted, the buffer re-enters `darkroom-mode'.
  40 ;;
  41 ;; Personally, I always use `darkroom-tentative-mode'.
  42 ;;
  43 ;; See also the customization options `darkroom-margins' and
  44 ;; `darkroom-fringes-outside-margins', which affect both modes.
  45
  46 ;;; Code:
  47
  48 (require 'cl-lib)
  49
  50 (defgroup darkroom nil
  51   "Remove visual distractions and focus on writing"
  52   :prefix "darkroom-"
  53   :group 'emulations)
  54
  55 (defcustom darkroom-margins 'darkroom-guess-margins
  56   "Margins to use in `darkroom-mode'.
  57
  58 Its value can be:
  59
  60 - a floating point value betweeen 0 and 1, specifies percentage of
  61   window width in columns to use as a margin.
  62
  63 - a cons cell (LEFT RIGHT) specifying the left and right margins
  64   in columns.
  65
  66 - a function of a single argument, a window, that returns a cons
  67   cell interpreted like the previous option. An example is
  68   `darkroom-guess-margins', which see. Beware that this function
  69   is called very often, so if it does some non-trivial processing
  70   on the buffer's text, consider caching that value.
  71
  72 Value is effective when `darkroom-mode' is toggled."
  73   :type '(choice float
  74                  (cons integer integer)
  75                  (function-item darkroom-guess-margins :doc "Guess margins")
  76                  (function darkroom-guess-margins))
  77   :group 'darkroom)
  78
  79 (defcustom darkroom-text-scale-increase 2
  80   "Steps to increase text size when in `darkroom-mode'.
  81 Value is passed to `text-scale-increase'."
  82   :type 'integer
  83   :group 'darkroom)
  84
  85 (defcustom darkroom-fringes-outside-margins t
  86   "If non-nil use fringes outside margins for `darkroom-mode'"
  87   :type 'boolean
  88   :group 'darkroom)
  89
  90 (defcustom darkroom-margin-increment 0.05
  91   "Increment to add used in `darkroom-increase-margins'."
  92   :type 'float
  93   :group 'darkroom)
  94
  95 (defcustom darkroom-margins-if-failed-guess 0.15
  96   "Margins when `darkroom-guess-margins' fails.
  97 If `darkroom-guess-margins' failed to figure out margins to
  98 center the text, use this percentage of window width for the
  99 symmetical margins."
 100   :type 'float
 101   :group 'darkroom)
 102
 103 (defcustom darkroom-verbose nil
 104   "If non-nil, be verbose about darkroom operations."
 105   :type 'boolean
 106   :group 'darkroom)
 107
 108 (defvar darkroom--guess-margins-statistics-cache nil
 109   "Cache used by `darkroom-guess-margins'.")
 110
 111 (defun darkroom--window-width (&optional window)
 112   "Calculate width of WINDOW in columns, considering text scaling.
 113 WINDOW defaults to the currently selected window. The function
 114 assumes the buffer to be filled with at least one character of an
 115 arbitrary, but fixed width. Narrowing is taken in consideration.
 116 The return value is a cons (COLS . SCALED-CHAR-WIDTH) where COLS
 117 is the desired width in columns and SCALED-CHAR-WIDTH is the
 118 width in pixels of a single character."
 119   (when (= (point-min) (point-max))
 120     (error "Cannot calculate the width of a single character"))
 121   (let* ((window (or window (selected-window)))
 122          (scaled-char-width (car (window-text-pixel-size
 123                                   window
 124                                   (point-min) (1+ (point-min)))))
 125          (char-width (frame-char-width))
 126          (margins (window-margins window)))
 127     (cons (truncate
 128            (+ (window-width window 'pixelwise)
 129               (* char-width (or (car margins) 0))
 130               (* char-width (or (cdr margins) 0)))
 131            scaled-char-width)
 132           scaled-char-width)))
 133
 134 (defun darkroom-guess-margins (window)
 135   "Guess suitable margins for `darkroom-margins'.
 136 If in suitable conditions, collect some statistics about the
 137 buffer's line lengths, and apply a heuristic to figure out how
 138 wide to set the margins, comparing it to WINDOW's width in
 139 columns. If the buffer's paragraphs are mostly filled to
 140 `fill-column', margins should center it on the window, otherwise,
 141 the margins specified in `darkroom-margins-if-failed-guess'.
 142
 143 In any of these conditions,`darkroom-margins-if-failed-guess' is
 144 also used:
 145
 146 * if `visual-line-mode' is on;
 147 * if `variable-pitch-mode' is on;
 148 * if the buffer is empty.
 149
 150 For testing purposes, WINDOW can also be an integer number which
 151 is a width in columns, in which case it will be used instead of a
 152 window's geometry."
 153   (if (or visual-line-mode
 154           (and buffer-face-mode
 155                (eq 'variable-pitch buffer-face-mode-face))
 156           (= (point-min) (point-max)))
 157       darkroom-margins-if-failed-guess
 158     (let* ((window-width-info (if (integerp window)
 159                                   window
 160                                 (darkroom--window-width window)))
 161            (window-width (car window-width-info))
 162            (scaled-char-width (cdr window-width-info))
 163            (top-quartile-avg
 164             (or darkroom--guess-margins-statistics-cache
 165                 (set
 166                  (make-local-variable 'darkroom--guess-margins-statistics-cache)
 167                  (let* ((line-widths
 168                          (save-excursion
 169                            (goto-char (point-min))
 170                            (cl-loop for start = (point)
 171                                     while (search-forward "\n"
 172                                                           20000
 173                                                           'no-error)
 174                                     for width = (truncate
 175                                                  (car
 176                                                   (window-text-pixel-size
 177                                                    window
 178                                                    start (1- (point))))
 179                                                  scaled-char-width)
 180                                     unless (zerop width)
 181                                     collect width)))
 182                         (n4 (max 1 (/ (length line-widths) 4))))
 183                    (/ (apply '+ (cl-subseq (sort line-widths '>) 0 n4)) n4))))))
 184       (cond
 185        ((> top-quartile-avg
 186            window-width)
 187         (message "Long lines detected. Consider turning on `visual-line-mode'")
 188         darkroom-margins-if-failed-guess)
 189        ((> top-quartile-avg (* 0.9 fill-column))
 190         ;; calculate margins so that `fill-column' + 1 colums are
 191         ;; centered on the window.
 192         ;;
 193         (let ((margin (truncate (* (- window-width (1+ fill-column))
 194                                    (/ (float scaled-char-width)
 195                                       (frame-char-width)))
 196                                 2)))
 197           (if darkroom-verbose
 198               (message "Choosing %s-wide margins based on fill-column %s"
 199                        margin fill-column))
 200           (cons margin margin)))
 201        (t
 202         darkroom-margins-if-failed-guess)))))
 203
 204 (defun darkroom--compute-margins (window)
 205   "From `darkroom-margins', computes desired margins for WINDOW."
 206   (let ((darkroom-margins
 207          (if (functionp darkroom-margins)
 208              (funcall darkroom-margins window)
 209            darkroom-margins)))
 210     (cond ((consp darkroom-margins)
 211            darkroom-margins)
 212           ((and (floatp darkroom-margins)
 213                 (< darkroom-margins 1))
 214            (let ((delta (darkroom--float-to-columns darkroom-margins)))
 215              (cons delta delta)))
 216           (t
 217            (error "Illegal value in `darkroom-margins'")))))
 218
 219 (defun darkroom--float-to-columns (f)
 220   (ceiling (* (let ((edges (window-edges)))
 221                 (- (nth 2 edges) (nth 0 edges)))
 222               f)))
 223
 224 (defvar darkroom--margin-factor 1
 225   "Buffer local factor affecting `darkroom--set-margins'")
 226
 227 (defun darkroom--set-margins ()
 228   "Set darkroom margins for currently selected window"
 229   (let* ((window-configuration-change-hook nil)
 230          (window (selected-window))
 231          (margins (darkroom--compute-margins window)))
 232     ;; See description of
 233     ;; `fringes-outside-margins' for the reason
 234     ;; for this apparent noop
 235     (set-window-buffer window (current-buffer))
 236     (set-window-margins window
 237                         (round
 238                          (* darkroom--margin-factor
 239                             (car margins)))
 240                         (round
 241                          (* darkroom--margin-factor
 242                             (cdr margins))))))
 243
 244 (defun darkroom--reset-margins ()
 245   "Reset darkroom margins for currently selected window."
 246   (set-window-margins (selected-window) 0 0))
 247
 248 (defun darkroom-increase-margins (increment)
 249   "Increase darkroom margins by INCREMENT."
 250   (interactive (list darkroom-margin-increment))
 251   (set (make-local-variable 'darkroom--margin-factor)
 252        (* darkroom--margin-factor (+ 1 increment)))
 253   (mapc #'(lambda (w)
 254             (with-selected-window w
 255               (darkroom--set-margins)))
 256         (get-buffer-window-list (current-buffer))))
 257
 258 (defun darkroom-decrease-margins (decrement)
 259   "Decrease darkroom margins by DECREMENT."
 260   (interactive (list darkroom-margin-increment))
 261   (darkroom-increase-margins (- decrement)))
 262
 263 (defvar darkroom-mode-map
 264   (let ((map (make-sparse-keymap)))
 265     (define-key map (kbd "C-M-+") 'darkroom-increase-margins)
 266     (define-key map (kbd "C-M--") 'darkroom-decrease-margins)
 267     map))
 268
 269 (defconst darkroom--saved-variables
 270   '(mode-line-format
 271     header-line-format
 272     fringes-outside-margins)
 273   "Variables saved in `darkroom--saved-state'")
 274
 275 (defvar darkroom--saved-state nil
 276   "Saved state before `darkroom-mode' is turned on.
 277 Alist of (VARIABLE . BEFORE-VALUE)")
 278
 279 ;; (defvar darkroom--saved-text-scale-mode-amount nil
 280 ;;   "Text scale before `darkroom-mode' is turned on.")
 281
 282 (defun darkroom--enter (&optional just-margins)
 283   "Save current state and enter darkroom for the current buffer.
 284 With optional JUST-MARGINS, just set the margins."
 285   (unless just-margins
 286     (setq darkroom--saved-state
 287           (mapcar #'(lambda (sym)
 288                       (cons sym (buffer-local-value sym (current-buffer))))
 289                   darkroom--saved-variables))
 290     (setq mode-line-format nil
 291           header-line-format nil
 292           fringes-outside-margins darkroom-fringes-outside-margins)
 293     (text-scale-increase darkroom-text-scale-increase))
 294   (mapc #'(lambda (w)
 295             (with-selected-window w
 296               (darkroom--set-margins)))
 297         (get-buffer-window-list (current-buffer))))
 298
 299 (defun darkroom--leave ()
 300   "Undo the effects of `darkroom--enter'."
 301   (mapc #'(lambda (pair)
 302             (set (make-local-variable (car pair)) (cdr pair)))
 303         darkroom--saved-state)
 304   (setq darkroom--saved-state nil)
 305   (text-scale-decrease darkroom-text-scale-increase)
 306   (mapc #'(lambda (w)
 307             (with-selected-window w
 308               (darkroom--reset-margins)))
 309         (get-buffer-window-list (current-buffer))))
 310
 311 (defun darkroom--enter-or-leave ()
 312   "Enter or leave darkroom according to window configuration."
 313   (cond ((= (count-windows) 1)
 314          (darkroom--enter darkroom--saved-state))
 315         (darkroom--saved-state
 316          (darkroom--leave))
 317         (t
 318          ;; for clarity, don't do anything
 319          )))
 320
 321 (define-minor-mode darkroom-mode
 322   "Remove visual distractions and focus on writing. When this
 323 mode is active, everything but the buffer's text is elided from
 324 view. The buffer margins are set so that text is centered on
 325 screen. Text size is increased (display engine allowing) by
 326 `darkroom-text-scale-increase'." nil nil nil
 327   (when darkroom-tentative-mode
 328     (display-warning
 329      'darkroom
 330      (concat "Turning off `darkroom-tentative-mode' first. "
 331              "It doesn't go with `darkroom-mode'.")
 332      (let ((darkroom-mode nil))
 333        (darkroom-tentative-mode -1))))
 334   (cond (darkroom-mode
 335          (darkroom--enter)
 336          (add-hook 'window-configuration-change-hook 'darkroom--set-margins
 337                    t t))
 338         (t
 339          (darkroom--leave)
 340          (remove-hook 'window-configuration-change-hook 'darkroom--set-margins
 341                       t))))
 342
 343 (define-minor-mode darkroom-tentative-mode
 344   "Enters `darkroom-mode' when all other windows are deleted."
 345   nil " Room" darkroom-mode-map
 346   ;; always begin by removing the hook
 347   ;;
 348   (remove-hook 'window-configuration-change-hook
 349                'darkroom--enter-or-leave 'local)
 350   (when darkroom-mode
 351     (display-warning
 352      'darkroom
 353      (concat "Turning off `darkroom-mode' first. "
 354              "It doesn't go with `darkroom-tentative-mode'.")
 355      (let ((darkroom-tentative-mode nil))
 356        (darkroom-mode -1))))
 357   ;; turn darkroom on or off according to window state
 358   ;;
 359   (cond (darkroom-tentative-mode
 360          ;; re-add the hook when we are turning ourselves on
 361          ;;
 362          (add-hook 'window-configuration-change-hook
 363                    'darkroom--enter-or-leave 'append 'local)
 364          ;; call this right away if we're supposed to turn darkroom on
 365          ;; immediately.
 366          ;;
 367          (darkroom--enter-or-leave))
 368         (t
 369          (darkroom--leave))))
 370
 371
 372
 373 (provide 'darkroom)
 374 ;;; darkroom.el ends here