code.delx.au - gnu-emacs-elpa/blob - 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-overlay
  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)
  56   "Compose A and B channels."
  57   (setq alpha (or alpha 0.5))
  58   (+ (* a alpha) (* b (- 1 alpha))))
  59
  60 (defun colir-blend (c1 c2)
  61   "Blend the two colors C1 and C2 using `colir-compose-method'.
  62 C1 and C2 are triples of floats in [0.0 1.0] range."
  63   (apply #'color-rgb-to-hex
  64          (cl-mapcar
  65           colir-compose-method
  66           c1 c2)))
  67
  68 (defun colir-blend-face-background (start end face &optional object)
  69   "Append to the face property of the text from START to END the face FACE.
  70 When the text already has a face with a non-plain background,
  71 blend it with the background of FACE.
  72 Optional argument OBJECT is the string or buffer containing the text.
  73 See also `font-lock-append-text-property'."
  74   (let (next prev)
  75     (while (/= start end)
  76       (setq next (next-single-property-change start 'face object end)
  77             prev (get-text-property start 'face object))
  78       (if prev
  79           (let ((background-prev (face-background prev)))
  80             (progn
  81               (put-text-property
  82                start next 'face
  83                (if background-prev
  84                    (cons `(background-color
  85                            . ,(colir-blend
  86                                (color-name-to-rgb background-prev)
  87                                (color-name-to-rgb (face-background face nil t))))
  88                          prev)
  89                  (list face prev))
  90                object)))
  91         (put-text-property start next 'face face object))
  92       (setq start next))))
  93
  94 (provide 'colir)
  95
  96 ;;; colir.el ends here