1 ;;; xpm-palette.el --- manage PX/COLOR set -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
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.
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.
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/>.
27 (defun xpm--palette-alist (cpp pinfo)
28 (cl-flet ((sub (beg len) (buffer-substring-no-properties
32 with (beg . ht) = pinfo
33 initially do (goto-char beg)
35 repeat (hash-table-count ht)
36 do (setq p (1+ (point))
39 (cons px (if (consp (setq color (gethash px ht)))
41 (goto-char (cl-incf p cpp))
44 with ls = (split-string
45 (sub p (skip-chars-forward "^\"")))
47 collect (cons (intern (pop ls))
51 finally do (goto-char bye))))
53 (defun xpm--validate-px (cpp px)
54 (when (/= cpp (length px))
55 (error "Invalid px %S (expecting length %d)" px cpp))
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))
65 (search-backward "\n\"")
66 (forward-char 2) ; LF, double-quote
67 (forward-sexp 2) ; WIDTH and HEIGHT
69 (count (string-to-number
70 (delete-and-extract-region
71 p (progn (forward-sexp 1)
73 (insert (format " %d" (cl-incf count n))))))
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)
84 (unless (or ent noerror)
85 (error "No such px: %S" px))
88 (xpm--adjust-npal -1 pinfo)
89 (re-search-forward (concat "^\"" px "\\s-.*$") origin)
90 (delete-region (match-beginning 0) (1+ (match-end 0)))
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:
102 Aside from ‘c’olor and ‘s’ymbolic, there is also ‘g’rayscale,
103 ‘m’onochrome and ‘g4’ (four-level gray scale).
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)))
111 (_ (error "Invalid COLOR: %S" color))))
113 (xpm--validate-px cpp px)
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 "^,")
121 (insert "\"" px " " (mapconcat
123 (format "%s %s" (car pair) (cdr pair)))
127 (puthash px alist ht))))
129 (provide 'xpm-palette)
131 ;;; xpm-palette.el ends here