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 alpha blended sum is used.
  28
  29 ;;; Code:
  30
  31 (defun colir-join (r g b)
  32   "Build a color from R G B.
  33 Inverse of `color-values'."
  34   (format "#%02x%02x%02x"
  35           (ash r -8)
  36           (ash g -8)
  37           (ash b -8)))
  38
  39 (defun colir-blend (c1 c2 &optional alpha)
  40   "Blend the two colors C1 and C2 with ALPHA.
  41 C1 and C2 are in the format of `color-values'.
  42 ALPHA is a number between 0.0 and 1.0 which corresponds to the
  43 influence of C1 on the result."
  44   (setq alpha (or alpha 0.5))
  45   (apply #'colir-join
  46          (cl-mapcar
  47           (lambda (x y)
  48             (round (+ (* x alpha) (* y (- 1 alpha)))))
  49           c1 c2)))
  50
  51 (defun colir-blend-face-background (start end face &optional object)
  52   "Append to the face property of the text from START to END the face FACE.
  53 When the text already has a face with a non-plain background,
  54 blend it with the background of FACE.
  55 Optional argument OBJECT is the string or buffer containing the text.
  56 See also `font-lock-append-text-property'."
  57   (let (next prev)
  58     (while (/= start end)
  59       (setq next (next-single-property-change start 'face object end)
  60             prev (get-text-property start 'face object))
  61       (if prev
  62           (let ((background-prev (face-background prev)))
  63             (progn
  64               (put-text-property
  65                start next 'face
  66                (if background-prev
  67                    (cons `(background-color
  68                            . ,(colir-blend
  69                                (color-values background-prev)
  70                                (color-values (face-background face nil t))))
  71                          prev)
  72                  (list face prev))
  73                object)))
  74         (put-text-property start next 'face face object))
  75       (setq start next))))
  76
  77 (provide 'colir)
  78
  79 ;;; colir.el ends here