Focus/focus.el

;;; focus.el --- Dim the font color of text in surrounding sections  -*- lexical-binding: t; -*-

;; Copyright (C) 2015  Lars Tveito

;; Author: Lars Tveito <larstvei@ifi.uio.no>
;; URL: http://github.com/larstvei/Focus
;; Created: 11th May 2015
;; Version: 1.0.0
;; Package-Requires: ((emacs "24.3") (cl-lib "0.5"))

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program 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 General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Focus provides `focus-mode` that dims the text of surrounding sections,
;; similar to [iA Writer's](https://ia.net/writer) Focus Mode.
;;
;; Enable the mode with `M-x focus-mode'.

;;; Code:

(require 'cl-lib)
(require 'face-remap)
(require 'org-element)
(require 'thingatpt)

(defgroup focus ()
  "Dim the font color of text in surrounding sections."
  :group 'font-lock
  :prefix "focus-")

(defcustom focus-mode-to-thing '((prog-mode . defun)
                                 (text-mode . paragraph)
                                 (org-mode . org-element))
  "An associated list between mode and thing.

A thing is defined in thingatpt.el; the thing determines the
narrowness of the focused section.

Note that the order of the list matters. The first mode that the
current mode is derived from is used, so more modes that have
many derivatives should be placed by the end of the list.

Things that are defined include `symbol', `list', `sexp',
`defun', `filename', `url', `email', `word', `sentence',
`whitespace', `line', and `page'."
  :type '(repeat symbol)
  :group 'focus)

(defcustom focus-read-only-blink-seconds 1
  "The duration of a cursor blink in `focus-read-only-mode'."
  :type '(float)
  :group 'focus)

(defcustom focus-fraction 0.5
  "Determines the amount of dimness in out of focus sections (0.0 – 1.0)."
  :type '(float)
  :group 'focus)

(defface focus-unfocused nil
  "The face that overlays the unfocused area."
  :group 'focus)

(defface focus-focused nil
  "The face that overlays the focused area."
  :group 'focus)

(defvar focus-cursor-type cursor-type
  "Used to restore the users `cursor-type'.")

(defvar-local focus-current-thing nil
  "Overrides the choice of thing dictated by `focus-mode-to-thing' if set.")

(defvar-local focus-buffer nil
  "Local reference to the buffer focus functions operate on.")

(defvar-local focus-pre-overlay nil
  "The overlay that dims the text prior to the current-point.")

(defvar-local focus-post-overlay nil
  "The overlay that dims the text past the current-point.")

(defvar-local focus-mid-overlays nil
  "These overlays restore original colors in the focused area.")

(defvar-local focus-remap-cookies nil
  "A list of cookies used for deleting the face remapping.")

(defvar-local focus-last-bounds nil
  "Used to identify changes in `focus-bounds'.")

(defvar-local focus-last-background nil
  "Used to identify changes in the background.")

(defvar-local focus-read-only-blink-timer nil
  "Timer started from `focus-read-only-cursor-blink'.
The timer calls `focus-read-only-hide-cursor' after
`focus-read-only-blink-seconds' seconds.")

(defun focus-lerp (c1 c2 d)
  "Interpolate C1 with C2, where D controls the amount."
  (apply 'color-rgb-to-hex
         (cl-mapcar (lambda (x y) (+ (* x (- 1 d)) (* y d))) c1 c2)))

(defun focus-remap-foreground-color-from-face (face)
  "Remap the foreground color of FACE to a dimmed color."
  (let ((fg (face-foreground face))
        (bg (face-background 'default)))
    (when (and fg bg (color-defined-p fg) (color-defined-p bg))
      (let* ((new-fg (focus-lerp (color-name-to-rgb fg)
                                 (color-name-to-rgb bg)
                                 focus-fraction))
             (cookie (face-remap-add-relative face `(:foreground ,new-fg))))
        (push cookie focus-remap-cookies)))))

(defun focus-reset-remapping ()
  "Clean up remappings stored in `focus-remap-cookies'."
  (while focus-remap-cookies
    (face-remap-remove-relative
     (pop focus-remap-cookies))))

(defun focus-dim-buffer ()
  "Dim the colors of relevant faces in the buffer."
  (focus-reset-remapping)
  ;; Most faces that alters the background are better left undimmed. The
  ;; default face is, however, a clear exception.
  (focus-remap-foreground-color-from-face 'default)
  (dolist (face (face-list))
    (when (and (not (face-background face))
               (face-foreground face))
      (focus-remap-foreground-color-from-face face))))

(defun focus-get-thing ()
  "Return the current thing, based on `focus-mode-to-thing'."
  (or focus-current-thing
      (let* ((modes (mapcar 'car focus-mode-to-thing))
             (mode  (or (cl-find major-mode modes)
                        (apply #'derived-mode-p modes))))
        (if mode (cdr (assoc mode focus-mode-to-thing)) 'sentence))))

(defun focus-bounds ()
  "Return the current bounds, based on `focus-get-thing'."
  (let ((thing (focus-get-thing)))
    (cond ((eq thing 'org-element)
           (let* ((elem (org-element-at-point))
                  (beg (org-element-property :begin elem))
                  (end (org-element-property :end elem)))
             (and beg end (cons beg end))))
          (t (bounds-of-thing-at-point thing)))))

(defun focus-make-focused-face (fg)
  "Add original foreground color FG to the `focus-focused` face."
  (plist-put (face-attr-construct 'focus-focused) :foreground fg))

(defun focus-foreground-from-face (face)
  "Return foreground color for FACE, or 'default if nil."
  (if (facep face)
      (face-attribute face :foreground)
    (face-attribute 'default :foreground)))

(defun focus-undim-area (low high)
  "Restore original colors between LOW and HIGH.

Returns the list of added overlays."
  (when (< low high)
    (let* ((next (min high (or (next-property-change low) high)))
           (face (get-text-property low 'face))
           (fg (focus-foreground-from-face face))
           (restored-face (focus-make-focused-face fg))
           (o (make-overlay low next)))
      (overlay-put o 'face restored-face)
      (cons o (focus-undim-area next high)))))

(defun focus-move-focus ()
  "Move the focused section according to `focus-bounds'.

If `focus-mode' is enabled, this command fires after each
command."
  (with-current-buffer focus-buffer
    (let* ((bounds (focus-bounds))
           (bg (face-background 'default)))
      (when (not (equal focus-last-background bg))
        (focus-dim-buffer))
      (when (and bounds (or (not (equal bg focus-last-background))
                            (not (equal bounds focus-last-bounds))))
        (let ((low (car bounds))
              (high (cdr bounds)))
          (focus-move-overlays low high)
          (mapc 'delete-overlay focus-mid-overlays)
          (setq focus-mid-overlays (focus-undim-area low high))))
      (setq focus-last-bounds bounds)
      (setq focus-last-background bg))))

(defun focus-move-overlays (low high)
  "Move `focus-pre-overlay' and `focus-post-overlay'."
  (move-overlay focus-pre-overlay (point-min) low)
  (move-overlay focus-post-overlay high (point-max)))

(defun focus-init ()
  "This function run when command `focus-mode' is enabled.

It sets the `focus-pre-overlay', `focus-min-overlay', and
`focus-post-overlay' to overlays; these are invisible until
`focus-move-focus' runs. It adds `focus-move-focus' to
`post-command-hook'."
  (unless (or focus-pre-overlay focus-post-overlay)
    (setq focus-pre-overlay (make-overlay (point-min) (point-min))
          focus-post-overlay (make-overlay (point-max) (point-max))
          focus-buffer (current-buffer))
    (overlay-put focus-pre-overlay 'face 'focus-unfocused)
    (overlay-put focus-post-overlay 'face 'focus-unfocused)
    (add-hook 'post-command-hook 'focus-move-focus t t)
    (add-hook 'change-major-mode-hook 'focus-terminate t t)
    (focus-move-focus)))

(defun focus-terminate ()
  "This function is run when command `focus-mode' is disabled.

Overlays are deleted. `focus-move-focus' is removed from
`post-command-hook'."
  (let ((overlays (append (list focus-pre-overlay
                                focus-post-overlay)
                          focus-mid-overlays)))
    (mapc (lambda (o) (and (overlayp o) (delete-overlay o))) overlays)
    (remove-hook 'post-command-hook 'focus-move-focus t)
    (focus-reset-remapping)
    (setq focus-pre-overlay nil
          focus-post-overlay nil
          focus-last-bounds nil
          focus-last-background nil)))

(defun focus-goto-thing (bounds)
  "Move point to the middle of BOUNDS."
  (when bounds
    (goto-char (/ (+ (car bounds) (cdr bounds)) 2))
    (recenter nil)))

(defun focus-change-thing ()
  "Adjust the narrowness of the focused section for the current buffer.

The variable `focus-mode-to-thing' dictates the default thing
according to major-mode. If `focus-current-thing' is set, this
default is overwritten. This function simply helps set the
`focus-current-thing'."
  (interactive)
  (let* ((candidates '(defun line list org-element paragraph sentence sexp symbol word))
         (thing (completing-read "Thing: " candidates)))
    (setq focus-current-thing (intern thing))))

(defun focus-pin ()
  "Pin the focused section to its current location or the region, if active."
  (interactive)
  (when (bound-and-true-p focus-mode)
    (when (region-active-p)
      (focus-move-overlays (region-beginning) (region-end)))
    (remove-hook 'post-command-hook 'focus-move-focus t)))

(defun focus-unpin ()
  "Unpin the focused section."
  (interactive)
  (when (bound-and-true-p focus-mode)
    (add-hook 'post-command-hook 'focus-move-focus nil t)))

(defun focus-next-thing (&optional n)
  "Move the point to the middle of the Nth next thing."
  (interactive "p")
  (let ((current-bounds (focus-bounds))
        (thing (focus-get-thing)))
    (forward-thing thing n)
    (when (equal current-bounds (focus-bounds))
      (forward-thing thing (cl-signum n)))
    (focus-goto-thing (focus-bounds))))

(defun focus-prev-thing (&optional n)
  "Move the point to the middle of the Nth previous thing."
  (interactive "p")
  (focus-next-thing (- n)))

(defun focus-read-only-hide-cursor ()
  "Hide the cursor.
This function is triggered by the `focus-read-only-blink-timer',
when `focus-read-only-mode' is activated."
  (with-current-buffer focus-buffer
    (when (and (bound-and-true-p focus-read-only-mode)
               (not (null focus-read-only-blink-timer)))
      (setq focus-read-only-blink-timer nil)
      (setq cursor-type nil))))

(defun focus-read-only-cursor-blink ()
  "Make the cursor visible for `focus-read-only-blink-seconds'.
This is added to the `pre-command-hook' when
`focus-read-only-mode' is active."
  (with-current-buffer focus-buffer
    (when (and (bound-and-true-p focus-read-only-mode)
               (not (member last-command '(focus-next-thing focus-prev-thing))))
      (when focus-read-only-blink-timer (cancel-timer focus-read-only-blink-timer))
      (setq cursor-type focus-cursor-type)
      (setq focus-read-only-blink-timer
            (run-at-time focus-read-only-blink-seconds nil
                         'focus-read-only-hide-cursor)))))

(defun focus-read-only-init ()
  "Run when `focus-read-only-mode' is activated.
Enables `read-only-mode', hides the cursor and adds
`focus-read-only-cursor-blink' to `pre-command-hook'.
Also `focus-read-only-terminate' is added to the `kill-buffer-hook'."
  (read-only-mode 1)
  (setq cursor-type nil
        focus-buffer (current-buffer))
  (add-hook 'pre-command-hook 'focus-read-only-cursor-blink nil t)
  (add-hook 'kill-buffer-hook 'focus-read-only-terminate nil t))

(defun focus-read-only-terminate ()
  "Run when `focus-read-only-mode' is deactivated.
Disables `read-only-mode' and shows the cursor again.
It cleans up the `focus-read-only-blink-timer' and hooks."
  (read-only-mode -1)
  (setq cursor-type focus-cursor-type)
  (when focus-read-only-blink-timer
    (cancel-timer focus-read-only-blink-timer))
  (setq focus-read-only-blink-timer nil)
  (remove-hook 'pre-command-hook 'focus-read-only-cursor-blink t)
  (remove-hook 'kill-buffer-hook 'focus-read-only-terminate t))

(defun focus-turn-off-focus-read-only-mode ()
  "Turn off `focus-read-only-mode'."
  (interactive)
  (focus-read-only-mode -1))

;;;###autoload
(define-minor-mode focus-mode
  "Dim the font color of text in surrounding sections."
  :init-value nil
  :keymap (let ((map (make-sparse-keymap)))
            (define-key map (kbd "C-c C-q") 'focus-read-only-mode)
            map)
  (if focus-mode (focus-init) (focus-terminate)))

;;;###autoload
(define-minor-mode focus-read-only-mode
  "A read-only mode optimized for `focus-mode'."
  :init-value nil
  :keymap (let ((map (make-sparse-keymap)))
            (define-key map (kbd "n") 'focus-next-thing)
            (define-key map (kbd "SPC") 'focus-next-thing)
            (define-key map (kbd "p") 'focus-prev-thing)
            (define-key map (kbd "S-SPC") 'focus-prev-thing)
            (define-key map (kbd "i") 'focus-turn-off-focus-read-only-mode)
            (define-key map (kbd "q") 'focus-turn-off-focus-read-only-mode)
            map)
  (when cursor-type
    (setq focus-cursor-type cursor-type))
  (if focus-read-only-mode (focus-read-only-init) (focus-read-only-terminate)))

(provide 'focus)
;;; focus.el ends here