code.delx.au - gnu-emacs-elpa/blob - packages/xpm/xpm-palette.el

   1 ;;; xpm-palette.el --- manage PX/COLOR set     -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19
  20 ;; TODO
  21
  22 ;;; Code:
  23
  24 (require 'cl-lib)
  25 (require 'xpm)
  26
  27 (defun xpm--palette-alist (cpp pinfo)
  28   (cl-flet ((sub (beg len) (buffer-substring-no-properties
  29                             beg (+ beg len))))
  30     (cl-loop
  31      with bye = (point)
  32      with (beg . ht) = pinfo
  33      initially do (goto-char beg)
  34      with (p px color)
  35      repeat (hash-table-count ht)
  36      do (setq p (1+ (point))
  37               px (sub p cpp))
  38      collect
  39      (cons px (if (consp (setq color (gethash px ht)))
  40                   color
  41                 (goto-char (cl-incf p cpp))
  42                 (puthash                ; optimism
  43                  px (cl-loop
  44                      with ls = (split-string
  45                                 (sub p (skip-chars-forward "^\"")))
  46                      while ls
  47                      collect (cons (intern (pop ls))
  48                                    (pop ls)))
  49                  ht)))
  50      do (forward-line 1)
  51      finally do (goto-char bye))))
  52
  53 (defun xpm--validate-px (cpp px)
  54   (when (/= cpp (length px))
  55     (error "Invalid px %S (expecting length %d)" px cpp))
  56   t)
  57
  58 (defun xpm--adjust-npal (n palette)
  59   ;; Change count of colors by adding N to the current value.
  60   ;; But first, move point to POS, which should be
  61   ;; the colors list bol (and leave it there when done).
  62   ;; See `xpm-drop-px' and `xpm-add-px'.
  63   (goto-char (car palette))
  64   (save-excursion
  65     (search-backward "\n\"")
  66     (forward-char 2)                    ; LF, double-quote
  67     (forward-sexp 2)                    ; WIDTH and HEIGHT
  68     (let* ((p (point))
  69            (count (string-to-number
  70                    (delete-and-extract-region
  71                     p (progn (forward-sexp 1)
  72                              (point))))))
  73       (insert (format " %d" (cl-incf count n))))))
  74
  75 (defun xpm-drop-px (px &optional noerror)
  76   "Drop PX from palette.
  77 Signal error if PX is not found.
  78 Optional arg NOERROR inhibits this.
  79 Return the deleted entry if PX was found."
  80   (xpm--w/gg (cpp pinfo origin) (xpm--gate)
  81     (let* ((ht (cdr pinfo))
  82            (ent (when (xpm--validate-px cpp px)
  83                   (gethash px ht))))
  84       (unless (or ent noerror)
  85         (error "No such px: %S" px))
  86       (when ent
  87         (remhash px ht)
  88         (xpm--adjust-npal -1 pinfo)
  89         (re-search-forward (concat "^\"" px "\\s-.*$") origin)
  90         (delete-region (match-beginning 0) (1+ (match-end 0)))
  91         ent))))
  92
  93 (defun xpm-add-px (px color &optional append)
  94   "Add an entry associating PX with COLOR to the palette.
  95 If COLOR is a string, it is associated using the ‘c’ type.
  96 Otherwise, it should be an alist with symbolic types and
  97 string values, for instance:
  98
  99  ((s . \"border\")
 100   (c . \"blue\"))
 101
 102 Aside from ‘c’olor and ‘s’ymbolic, there is also ‘g’rayscale,
 103 ‘m’onochrome and ‘g4’ (four-level gray scale).
 104
 105 The new entry is normally added to the front.
 106 Optional arg APPEND non-nil means add it to the rear."
 107   (xpm--w/gg (cpp pinfo origin) (xpm--gate)
 108     (let ((alist (pcase color
 109                    ((pred stringp) (list (cons 'c color)))
 110                    ((pred consp) color)
 111                    (_ (error "Invalid COLOR: %S" color))))
 112           (ht (cdr pinfo)))
 113       (xpm--validate-px cpp px)
 114       (xpm-drop-px px t)
 115       (xpm--adjust-npal 1 pinfo)
 116       (unless (or (not append)
 117                   (zerop (hash-table-count ht)))
 118         (goto-char (1- origin))
 119         (skip-chars-backward "^,")
 120         (forward-line 1))
 121       (insert "\"" px "  " (mapconcat
 122                             (lambda (pair)
 123                               (format "%s %s" (car pair) (cdr pair)))
 124                             alist
 125                             " ")
 126               "\",\n")
 127       (puthash px alist ht))))
 128
 129 (provide 'xpm-palette)
 130
 131 ;;; xpm-palette.el ends here