[elpa] 01/01: This ephemeral branch holds unfinished bits of package ‘xpm’ that should be refined Someday by Someone for a future release. If you have ELPA write privs, then please hack freely and ping me when you think something is ready for merging into the package proper. (I reserve the right to do the merge.) --ttn

[Thien-Thi Nguyen]

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

commit 45e00d7d2e0ddb712d7b330a64daa807f4aee647
Author: Thien-Thi Nguyen <address@hidden>
Date:   Sun May 18 01:54:20 2014 +0200

    This ephemeral branch holds unfinished bits of package ‘xpm’
    that should be refined Someday by Someone for a future release.
    If you have ELPA write privs, then please hack freely and ping
    me when you think something is ready for merging into the
    package proper.  (I reserve the right to do the merge.)  --ttn
---
 packages/xpm/xpm-compose.el |  142 +++++++++++++++++++++++++++++++++++++++++++
 packages/xpm/xpm-ops.el     |   63 +++++++++++++++++++
 packages/xpm/xpm-palette.el |  130 +++++++++++++++++++++++++++++++++++++++
 packages/xpm/xpm-ui.el      |   84 +++++++++++++++++++++++++
 4 files changed, 419 insertions(+), 0 deletions(-)

diff --git a/packages/xpm/xpm-compose.el b/packages/xpm/xpm-compose.el
new file mode 100644
index 0000000..61107b9
--- /dev/null
+++ b/packages/xpm/xpm-compose.el
@@ -0,0 +1,142 @@
+;;; xpm-compose.el --- two or more buffers     -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; 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 'xpm)
+(require 'cl-lib)
+
+(defun xpm--lines ()
+  ;; (maybe) todo: use rectangle funcs
+  (xpm--w/gg (w h origin flags) xpm--gg
+    (save-excursion
+      (goto-char origin)
+      (loop with skip = (if (memq 'intangible-sides flags)
+                            1
+                          4)
+            repeat h
+            collect (let ((p (point)))
+                      (forward-char w)
+                      (prog1 (buffer-substring-no-properties p (point))
+                        (forward-char skip)))))))
+
+(defun xpm--clone (src)
+  (insert-buffer-substring src)
+  (setq xpm--gg (xpm--copy-gg (buffer-local-value 'xpm--gg src))))
+
+(defun xpm-buffer-from (image &optional name)
+  "Return a new XPM buffer initialized from IMAGE.
+IMAGE should have type `xpm'.  NAME is the new buffer name,
+which defaults to the name specified in IMAGE."
+  (let* ((plist (cdr image))
+         source populate)
+    (cond ((setq source (plist-get plist :file))
+           (setq populate 'insert-file-contents))
+          ((setq source (plist-get plist :data))
+           (setq populate 'insert))
+          (t (error "Invalid image: %S" image)))
+    (with-current-buffer (generate-new-buffer
+                          (or name "*TMP* for xpm-buffer-from"))
+      (funcall populate source)
+      (unless name
+        (goto-char (point-min))
+        (re-search-forward "\\(\\S-+\\)\\[\\]")
+        (rename-buffer (match-string 1)))
+      (current-buffer))))
+
+(defun xpm-compose (name one two px)
+  "Return new buffer NAME, by composing buffers ONE and TWO.
+This copies all pixels from TWO that are not PX."
+  (when (characterp px)
+    (setq px (string px)))
+  (with-current-buffer (generate-new-buffer name)
+    (xpm--w/gg (w h cpp origin flags) (xpm--clone one)
+      (let ((lines (with-current-buffer two
+                     (xpm--lines))))
+        ;; fluency from congruency...
+        (assert (= cpp (length px)))
+        (assert (= h (length lines)))
+        (assert (or (zerop h)           ; GIGO :-/
+                    (= (* cpp w) (length (car lines)))))
+        ;; do it
+        (goto-char origin)
+        (loop with skip = (if (memq 'intangible-sides flags)
+                              1
+                            4)
+              for line in lines
+              do (loop
+                  ;; this is slow and stupid
+                  ;; todo: use ‘compare-strings’
+                  for x below w
+                  do (let* ((i (* x cpp))
+                            (el (substring line i (+ i cpp))))
+                       (if (string= px el)
+                           (forward-char cpp)
+                         (insert el)
+                         (delete-char cpp))))
+              do (when (< (point) (point-max))
+                   (forward-char skip)))
+        (current-buffer)))))
+
+(defun xpm-fill (px)
+  "Fill with PX."
+  (interactive "sPX: ")
+  (xpm--w/gg (w h) (xpm--gate)
+    (save-excursion
+      (loop with x = (cons 0 (1- w))
+            for y below h
+            do (xpm-put-points px x y)))))
+
+(provide 'xpm-compose)
+
+
+(defun ttn-test-xpm-compose ()
+  (interactive)
+  (cl-flet ((zonk (name) (let ((buf (get-buffer name)))
+                           (when buf (kill-buffer buf)))))
+    (mapc #'zonk '("one" "two" "zow"))
+    ;; create
+    (let* ((palette '((?\s . "black")   ; bg
+                      (?#  . "green")   ; fg
+                      (?X  . "red")
+                      (?-  . "None")))
+           (one (xpm-generate-buffer "one" 10 10 1 palette))
+           (two (xpm-generate-buffer "two" 10 10 1 palette)))
+      (with-current-buffer one (xpm-fill ?#))
+      (with-current-buffer two
+        (xpm-fill ?-)
+        (cl-flet
+            ((vec () (let ((v (make-vector 42 nil)))
+                       (loop for i below 42
+                             do (aset v i (random 10)))
+                       v)))
+          (xpm-put-points ?\s (vec) (vec))))
+      (assert (and (bufferp one)
+                   (bufferp two))))
+    ;; mogrify
+    (let* ((debug-ignored-errors nil)
+           (one (get-buffer "one"))
+           (two (get-buffer "two"))
+           (zow (xpm-compose "zow" one two ?-)))
+      (when (bufferp zow)
+        (switch-to-buffer zow)))))
+
+;;; xpm-compose.el ends here
diff --git a/packages/xpm/xpm-ops.el b/packages/xpm/xpm-ops.el
new file mode 100644
index 0000000..67989ca
--- /dev/null
+++ b/packages/xpm/xpm-ops.el
@@ -0,0 +1,63 @@
+;;; xpm-ops.el --- drawing operations        -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; 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:
+
+;;; Code:
+
+(require 'queue)
+
+(defun xpm-flood-fill (px x y)
+  (xpm--w/gg (cpp origin y-mult) (xpm--gate)
+    (let ((q (queue-create))
+          bye)
+      (cl-labels
+          ((pos (x y) (+ origin (* cpp x) (* y-mult y)))
+           (cur () (let ((p (point)))
+                     (buffer-substring-no-properties
+                      p (+ p cpp))))
+           (oldp () (string= bye (cur)))
+           (extent (coord)
+                   (let* ((x (car coord))
+                          (y (cdr coord))
+                          (p (goto-char (pos x y)))
+                          (beg x)
+                          (end x))
+                     (when (oldp)
+                       (loop while (oldp)
+                             do (backward-char cpp)
+                             do (decf beg)
+                             finally do (incf beg))
+                       (goto-char p)
+                       (loop while (oldp)
+                             do (forward-char cpp)
+                             do (incf end)
+                             finally do (decf end))
+                       (cons beg end)))))
+        (setq bye (let ((p (pos x y)))
+                    (buffer-substring-no-properties
+                     p (+ p cpp))))
+        (queue-enqueue q (cons x y))
+        (loop until (queue-empty q)
+              do (let* ((coord (queue-dequeue q))
+                        (ext (extent coord)))
+                   (when ext
+                     (xpm-put-points px ext y)
+                     ;; todo: expansion and queuing of y-1 and y+1
+                     )))))))
+
+;;; xpm-ops.el ends here
diff --git a/packages/xpm/xpm-palette.el b/packages/xpm/xpm-palette.el
new file mode 100644
index 0000000..ff93890
--- /dev/null
+++ b/packages/xpm/xpm-palette.el
@@ -0,0 +1,130 @@
+;;; xpm-palette.el --- manage PX/COLOR set     -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; 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
diff --git a/packages/xpm/xpm-ui.el b/packages/xpm/xpm-ui.el
new file mode 100644
index 0000000..2f4e440
--- /dev/null
+++ b/packages/xpm/xpm-ui.el
@@ -0,0 +1,84 @@
+;;; xpm-ui.el --- xpm-* plus pretty redisplay   -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; 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
+;;
+;; ??? hmm, since this will probably be the future home of xpm-mode,
+;;     why not rename the file as xpm-mode.el?
+
+;;; Code:
+
+;; todo: var ‘xpm-current-px’ (or maybe ‘xpm-quill’)
+
+(defun xpm-set-pen-func (parent normal none)
+  (lexical-let ((parent parent))
+    (lambda (color)
+      ;; see "hang" below
+      (let* ((was (current-buffer))
+             (px (get-text-property 0 'px color))
+             (again (assoc px normal)))
+        (switch-to-buffer parent)
+        (message "%S | %S %s | %S" was px color again)))))
+
+(defun xpm-list-palette-display ()
+  "Display palette in another buffer."
+  (interactive)
+  (xpm--w/gg (cpp pinfo) (xpm--gate)
+    (let ((inhibit-read-only t)
+          (name (format "*%s Palette*" (buffer-name)))
+          normal none)
+      ;; normalize and extract "None" if necessary
+      (loop for (px . alist) in (xpm--palette-alist cpp pinfo)
+            ;; todo: handle case where there is no ‘c’
+            do (let ((color (cdr (assq 'c alist))))
+                 (if (member color '("none" "None"))
+                     (setq none px)
+                   (push (cons px color)
+                         normal)))
+            finally do (setq normal (nreverse normal)))
+      (list-colors-display (mapcar 'cdr normal) name
+                           (xpm-set-pen-func (current-buffer)
+                                             normal
+                                             none))
+      (switch-to-buffer name)
+      (delete-other-windows)
+      (goto-char (point-min))
+      ;; ugly; better to not ‘insert’ and just add text properties.
+      ;; also, focus is on px so we can hang it on ‘color-name’ directly
+      (when none
+        (insert (propertize (format "%S\tnone" none)
+                            'color-name (propertize "none" 'px none))
+                "\n"))
+      (while normal
+        (let* ((px (car (pop normal)))
+               (all (text-properties-at (point)))
+               (color (plist-get all 'color-name))
+               (button (plist-get all 'button))
+               (action (plist-get all 'action)))
+          (insert (propertize
+                   (format "%S\t" px)
+                   'color-name (propertize color 'px px)
+                   'button button
+                   'action action
+                   'category 'default-button
+                   'follow-link t)))
+        (forward-line 1))
+      (goto-char (point-min)))))
+
+;;; xpm-ui.el ends here