1 ;;; xpm-compose.el --- two or more buffers -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, either version 3 of the License, or
8 ;; (at your option) any later version.
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
28 ;; (maybe) todo: use rectangle funcs
29 (xpm--w/gg (w h origin flags) xpm--gg
32 (cl-loop with skip = (if (memq 'intangible-sides flags)
36 collect (let ((p (point)))
38 (prog1 (buffer-substring-no-properties p (point))
39 (forward-char skip)))))))
41 (defun xpm--clone (src)
42 (insert-buffer-substring src)
43 (setq xpm--gg (xpm--copy-gg (buffer-local-value 'xpm--gg src))))
45 (defun xpm-buffer-from (image &optional name)
46 "Return a new XPM buffer initialized from IMAGE.
47 IMAGE should have type `xpm'. NAME is the new buffer name,
48 which defaults to the name specified in IMAGE."
49 (let* ((plist (cdr image))
51 (cond ((setq source (plist-get plist :file))
52 (setq populate 'insert-file-contents))
53 ((setq source (plist-get plist :data))
54 (setq populate 'insert))
55 (t (error "Invalid image: %S" image)))
56 (with-current-buffer (generate-new-buffer
57 (or name "*TMP* for xpm-buffer-from"))
58 (funcall populate source)
60 (goto-char (point-min))
61 (re-search-forward "\\(\\S-+\\)\\[\\]")
62 (rename-buffer (match-string 1)))
65 (defun xpm-compose (name one two px)
66 "Return new buffer NAME, by composing buffers ONE and TWO.
67 This copies all pixels from TWO that are not PX."
69 (setq px (string px)))
70 (with-current-buffer (generate-new-buffer name)
71 (xpm--w/gg (w h cpp origin flags) (xpm--clone one)
72 (let ((lines (with-current-buffer two
74 ;; fluency from congruency...
75 (cl-assert (= cpp (length px)))
76 (cl-assert (= h (length lines)))
77 (cl-assert (or (zerop h) ; GIGO :-/
78 (= (* cpp w) (length (car lines)))))
81 (cl-loop with skip = (if (memq 'intangible-sides flags)
86 ;; this is slow and stupid
87 ;; todo: use ‘compare-strings’
89 do (let* ((i (* x cpp))
90 (el (substring line i (+ i cpp))))
95 do (when (< (point) (point-max))
101 (interactive "sPX: ")
102 (xpm--w/gg (w h) (xpm--gate)
104 (cl-loop with x = (cons 0 (1- w))
106 do (xpm-put-points px x y)))))
108 (provide 'xpm-compose)
111 (defun ttn-test-xpm-compose ()
113 (cl-flet ((zonk (name) (let ((buf (get-buffer name)))
114 (when buf (kill-buffer buf)))))
115 (mapc #'zonk '("one" "two" "zow"))
117 (let* ((palette '((?\s . "black") ; bg
121 (one (xpm-generate-buffer "one" 10 10 1 palette))
122 (two (xpm-generate-buffer "two" 10 10 1 palette)))
123 (with-current-buffer one (xpm-fill ?#))
124 (with-current-buffer two
127 ((vec () (let ((v (make-vector 42 nil)))
128 (cl-loop for i below 42
129 do (aset v i (random 10)))
131 (xpm-put-points ?\s (vec) (vec))))
132 (cl-assert (and (bufferp one)
135 (let* ((debug-ignored-errors nil)
136 (one (get-buffer "one"))
137 (two (get-buffer "two"))
138 (zow (xpm-compose "zow" one two ?-)))
140 (switch-to-buffer zow)))))
142 ;;; xpm-compose.el ends here