code.delx.au - gnu-emacs-elpa/blob - packages/swiper/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           colir-compose-method
  67           c1 c2)))
  68
  69 (defun colir-blend-face-background (start end face &optional object)
  70   "Append to the face property of the text from START to END the face FACE.
  71 When the text already has a face with a non-plain background,
  72 blend it with the background of FACE.
  73 Optional argument OBJECT is the string or buffer containing the text.
  74 See also `font-lock-append-text-property'."
  75   (let (next prev)
  76     (while (/= start end)
  77       (setq next (next-single-property-change start 'face object end)
  78             prev (get-text-property start 'face object))
  79       (when (listp prev)
  80         (setq prev (cl-find-if #'atom prev)))
  81       (if prev
  82           (let ((background-prev (face-background prev)))
  83             (progn
  84               (put-text-property
  85                start next 'face
  86                (if background-prev
  87                    (cons `(background-color
  88                            . ,(colir-blend
  89                                (color-name-to-rgb background-prev)
  90                                (color-name-to-rgb (face-background face nil t))))
  91                          prev)
  92                  (list face prev))
  93                object)))
  94         (put-text-property start next 'face face object))
  95       (setq start next))))
  96
  97 (provide 'colir)
  98
  99 ;;; colir.el ends here