ttn pushed a commit to branch ttn-xpm
in repository elpa.
commit 21da1f12da1ca7be18a486525d0191b08d2b3ef1
Author: Thien-Thi Nguyen <t...@gnu.org>
Date: Tue May 13 12:42:56 2014 +0200
add xpm-compose.el
---
packages/xpm/xpm-compose.el | 125 +++++++++++++++++++++++++++++++++++++++++++
1 files changed, 125 insertions(+), 0 deletions(-)
diff --git a/packages/xpm/xpm-compose.el b/packages/xpm/xpm-compose.el
new file mode 100644
index 0000000..0a8bddb
--- /dev/null
+++ b/packages/xpm/xpm-compose.el
@@ -0,0 +1,125 @@
+;;; xpm-compose.el --- two or more buffers -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author: Thien-Thi Nguyen <t...@gnu.org>
+;; 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 '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-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-buffer "one" 10 10 1 palette))
+ (two (xpm-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
