emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/xpm 9e50d40 26/37: [xpm int] Make wip more visible; in


From: Stefan Monnier
Subject: [elpa] externals/xpm 9e50d40 26/37: [xpm int] Make wip more visible; inhibit their distribution.
Date: Sat, 28 Nov 2020 14:15:35 -0500 (EST)

branch: externals/xpm
commit 9e50d403c743ed0e034bbbbbad395e8e293d107c
Author: Thien-Thi Nguyen <ttn@gnu.org>
Commit: Thien-Thi Nguyen <ttn@gnu.org>

    [xpm int] Make wip more visible; inhibit their distribution.
    
    * packages/xpm/xpm-compose.el: New file.
    * packages/xpm/xpm-ops.el: New file.
    * packages/xpm/xpm-palette.el: New file.
    * packages/xpm/xpm-ui.el: New file.
    * packages/xpm/.elpaignore: Update.
---
 .elpaignore    |   4 ++
 HACKING        |  23 +++++++++-
 xpm-compose.el | 142 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 xpm-ops.el     |  63 +++++++++++++++++++++++++
 xpm-palette.el | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 xpm-ui.el      |  84 ++++++++++++++++++++++++++++++++++
 6 files changed, 444 insertions(+), 2 deletions(-)

diff --git a/.elpaignore b/.elpaignore
index dd69f33..2336dba 100644
--- a/.elpaignore
+++ b/.elpaignore
@@ -1,2 +1,6 @@
 HACKING
 flower.el
+xpm-compose.el
+xpm-ops.el
+xpm-palette.el
+xpm-ui.el
diff --git a/HACKING b/HACKING
index ff04c62..a682210 100644
--- a/HACKING
+++ b/HACKING
@@ -3,7 +3,26 @@ HACKING xpm.el (et al)                                     -*- 
org -*-
 This file is both a guide for newcomers and a todo list for oldstayers.
 
 * ideas / wishlist
-*** add xpm-mode for interactive use
+*** lacunae (sigh)
+(defun xpm-as-rectangle ()
+  (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
+    (extract-rectangle
+     origin
+     (+ origin (* y-mult (1- h)) (* w cpp)))))
+
+(defun xpm-from-rectangle (rect)
+  (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
+    (assert (= h (length rect)))
+    (assert (= (* w cpp) (length (car rect))))
+    (goto-char origin)
+    (delete-rectangle origin (+ origin (* y-mult (1- h)) (* w cpp)))
+    (insert-rectangle rect)))
+
+(defun xpm-replace-from (buffer)
+  (xpm-from-rectangle
+   (with-current-buffer buffer
+     (xpm-as-rectangle))))
+*** add xpm-mode for interactive use -- [[file:xpm-ui.el][xpm-ui.el]]
 ***** hide/show header lines
 ***** palette
 ******* hide/show
@@ -11,7 +30,7 @@ This file is both a guide for newcomers and a todo list for 
oldstayers.
 ******* display as table (conserve vertical space)
 ******* add state "current px", commands to set it
 ***** hide/show sides
-*** composition facilities
+*** composition facilities -- [[file:xpm-compose.el][xpm-compose.el]]
 ***** multilevel congruence
 ******* dimensions only
 ******* palette not None
diff --git a/xpm-compose.el b/xpm-compose.el
new file mode 100644
index 0000000..61107b9
--- /dev/null
+++ b/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/xpm-ops.el b/xpm-ops.el
new file mode 100644
index 0000000..67989ca
--- /dev/null
+++ b/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/xpm-palette.el b/xpm-palette.el
new file mode 100644
index 0000000..ff93890
--- /dev/null
+++ b/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/xpm-ui.el b/xpm-ui.el
new file mode 100644
index 0000000..2f4e440
--- /dev/null
+++ b/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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]