[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] 01/01: [xpm int] Make wip more visible; inhibit their distributio
|
From: |
Thien-Thi Nguyen |
|
Subject: |
[elpa] 01/01: [xpm int] Make wip more visible; inhibit their distribution. |
|
Date: |
Fri, 13 Jun 2014 12:49:41 +0000 |
ttn pushed a commit to branch master
in repository elpa.
commit 2a6deb8cdea4516d78639d9d50f247f2981e95d1
Author: Thien-Thi Nguyen <address@hidden>
Date: Fri Jun 13 14:52:47 2014 +0200
[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.
---
packages/xpm/.elpaignore | 4 +
packages/xpm/HACKING | 23 ++++++-
packages/xpm/xpm-compose.el | 142 +++++++++++++++++++++++++++++++++++++++++++
packages/xpm/xpm-ops.el | 63 +++++++++++++++++++
packages/xpm/xpm-palette.el | 130 +++++++++++++++++++++++++++++++++++++++
packages/xpm/xpm-ui.el | 84 +++++++++++++++++++++++++
6 files changed, 444 insertions(+), 2 deletions(-)
diff --git a/packages/xpm/.elpaignore b/packages/xpm/.elpaignore
index dd69f33..2336dba 100644
--- a/packages/xpm/.elpaignore
+++ b/packages/xpm/.elpaignore
@@ -1,2 +1,6 @@
HACKING
flower.el
+xpm-compose.el
+xpm-ops.el
+xpm-palette.el
+xpm-ui.el
diff --git a/packages/xpm/HACKING b/packages/xpm/HACKING
index ff04c62..a682210 100644
--- a/packages/xpm/HACKING
+++ b/packages/xpm/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/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