code.delx.au - gnu-emacs-elpa/blob - packages/ivy/colir.el

   1 ;;; colir.el --- Color blending library -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 3, or (at your option)
  12 ;; any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; For a full copy of the GNU General Public License
  20 ;; see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; This package solves the problem of adding a face with a background
  25 ;; to text which may already have a background.  In all conflicting
  26 ;; areas, instead of choosing either the original or the new
  27 ;; background face, their blended sum is used.
  28 ;;
  29 ;; The blend mode functions are taken from http://en.wikipedia.org/wiki/Blend_modes.
  30
  31 ;;; Code:
  32
  33 (require 'color)
  34
  35 (defcustom colir-compose-method 'colir-compose-alpha
  36   "Select a method to compose two color channels."
  37   :type '(choice
  38           (const colir-compose-alpha)
  39           (const colir-compose-overlay)
  40           (const colir-compose-soft-light))
  41   :group 'ivy)
  42
  43 (defun colir-compose-soft-light (a b)
  44   "Compose A and B channels."
  45   (if (< b 0.5)
  46       (+ (* 2 a b) (* a a (- 1 b b)))
  47     (+ (* 2 a (- 1 b)) (* (sqrt a) (- (* 2 b) 1)))))
  48
  49 (defun colir-compose-overlay (a b)
  50   "Compose A and B channels."
  51   (if (< a 0.5)
  52       (* 2 a b)
  53     (- 1 (* 2 (- 1 a) (- 1 b)))))
  54
  55 (defun colir-compose-alpha (a b &optional alpha gamma)
  56   "Compose A and B channels."
  57   (setq alpha (or alpha 0.5))
  58   (setq gamma (or gamma 2.2))
  59   (+ (* (expt a gamma) alpha) (* (expt b gamma) (- 1 alpha))))
  60
  61 (defun colir-blend (c1 c2)
  62   "Blend the two colors C1 and C2 using `colir-compose-method'.
  63 C1 and C2 are triples of floats in [0.0 1.0] range."
  64   (apply #'color-rgb-to-hex
  65          (cl-mapcar
  66           (if (eq (frame-parameter nil 'background-mode) 'dark)
  67               ;; this method works nicely for dark themes
  68               'colir-compose-soft-light
  69             colir-compose-method)
  70           c1 c2)))
  71
  72 (defun colir-blend-face-background (start end face &optional object)
  73   "Append to the face property of the text from START to END the face FACE.
  74 When the text already has a face with a non-plain background,
  75 blend it with the background of FACE.
  76 Optional argument OBJECT is the string or buffer containing the text.
  77 See also `font-lock-append-text-property'."
  78   (let (next prev)
  79     (while (/= start end)
  80       (setq next (next-single-property-change start 'face object end))
  81       (setq prev (get-text-property start 'face object))
  82       (when (listp prev)
  83         (setq prev (cl-find-if #'atom prev)))
  84       (if (facep prev)
  85           (let ((background-prev (face-background prev)))
  86             (progn
  87               (put-text-property
  88                start next 'face
  89                (if background-prev
  90                    (cons `(background-color
  91                            . ,(colir-blend
  92                                (color-name-to-rgb background-prev)
  93                                (color-name-to-rgb (face-background face nil t))))
  94                          prev)
  95                  (list face prev))
  96                object)))
  97         (put-text-property start next 'face face object))
  98       (setq start next))))
  99
 100 (provide 'colir)
 101
 102 ;;; colir.el ends here