[elpa] 04/07: add xpm-palette.el

[Thien-Thi Nguyen]

ttn pushed a commit to branch ttn-xpm
in repository elpa.

commit c21a498dddb6d5ad85c6472a21a2250315ede262
Author: Thien-Thi Nguyen <address@hidden>
Date:   Tue May 13 12:41:48 2014 +0200

    add xpm-palette.el
---
 packages/xpm/xpm-palette.el |  133 +++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 133 insertions(+), 0 deletions(-)

diff --git a/packages/xpm/xpm-palette.el b/packages/xpm/xpm-palette.el
new file mode 100644
index 0000000..3e703c9
--- /dev/null
+++ b/packages/xpm/xpm-palette.el
@@ -0,0 +1,133 @@
+;;; xpm-palette.el --- manage PX/COLOR set     -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; Author: Thien-Thi Nguyen <address@hidden>
+;; Version: -1
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; TODO
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defun xpm--palette-alist (cpp pinfo)
+  (cl-flet ((sub (beg len) (buffer-substring-no-properties
+                            beg (+ beg len))))
+    (loop
+     with bye = (point)
+     with (beg . ht) = pinfo
+     initially do (goto-char beg)
+     with (p px color)
+     repeat (hash-table-count ht)
+     do (setq p (1+ (point))
+              px (sub p cpp))
+     collect
+     (cons px (if (consp (setq color (gethash px ht)))
+                  color
+                (goto-char (incf p cpp))
+                (puthash                ; optimism
+                 px (loop
+                     with ls = (split-string
+                                (sub p (skip-chars-forward "^\"")))
+                     while ls
+                     collect (cons (intern (pop ls))
+                                   (pop ls)))
+                 ht)))
+     do (forward-line 1)
+     finally do (goto-char bye))))
+
+(defun xpm--validate-px (cpp px)
+  (when (/= cpp (length px))
+    (error "Invalid px %S (expecting length %d)" px cpp))
+  t)
+
+(defun xpm--adjust-npal (n palette)
+  ;; Change count of colors by adding N to the current value.
+  ;; But first, move point to POS, which should be
+  ;; the colors list bol (and leave it there when done).
+  ;; See `xpm-drop-px' and `xpm-add-px'.
+  (goto-char (car palette))
+  (save-excursion
+    (search-backward "\n\"")
+    (forward-char 2)                    ; LF, double-quote
+    (forward-sexp 2)                    ; WIDTH and HEIGHT
+    (let* ((p (point))
+           (count (string-to-number
+                   (delete-and-extract-region
+                    p (progn (forward-sexp 1)
+                             (point))))))
+      (insert (format " %d" (incf count n))))))
+
+(defun xpm-drop-px (px &optional noerror)
+  "Drop PX from palette.
+Signal error if PX is not found.
+Optional arg NOERROR inhibits this.
+Return the deleted entry if PX was found."
+  (xpm--w/gg (cpp pinfo origin) (xpm--gate)
+    (let* ((ht (cdr pinfo))
+           (ent (when (xpm--validate-px cpp px)
+                  (gethash px ht))))
+      (unless (or ent noerror)
+        (error "No such px: %S" px))
+      (when ent
+        (remhash px ht)
+        (xpm--adjust-npal -1 pinfo)
+        (re-search-forward (concat "^\"" px "\\s-.*$") origin)
+        (delete-region (match-beginning 0) (1+ (match-end 0)))
+        ent))))
+
+(defun xpm-add-px (px color &optional append)
+  "Add an entry associating PX with COLOR to the palette.
+If COLOR is a string, it is associated using the ‘c’ type.
+Otherwise, it should be an alist with symbolic types and
+string values, for instance:
+
+ ((s . \"border\")
+  (c . \"blue\"))
+
+Aside from ‘c’olor and ‘s’ymbolic, there is also ‘g’rayscale,
+‘m’onochrome and ‘g4’ (four-level gray scale).
+
+The new entry is normally added to the front.
+Optional arg APPEND non-nil means add it to the rear."
+  (xpm--w/gg (cpp pinfo origin) (xpm--gate)
+    (let ((alist (pcase color
+                   ((pred stringp) (list (cons 'c color)))
+                   ((pred consp) color)
+                   (_ (error "Invalid COLOR: %S" color))))
+          (ht (cdr pinfo)))
+      (xpm--validate-px cpp px)
+      (xpm-drop-px px t)
+      (xpm--adjust-npal 1 pinfo)
+      (unless (or (not append)
+                  (zerop (hash-table-count ht)))
+        (goto-char (1- origin))
+        (skip-chars-backward "^,")
+        (forward-line 1))
+      (insert "\"" px "  " (mapconcat
+                            (lambda (pair)
+                              (format "%s %s" (car pair) (cdr pair)))
+                            alist
+                            " ")
+              "\",\n")
+      (puthash px alist ht))))
+
+(provide 'xpm-palette)
+
+;;; xpm-palette.el ends here