code.delx.au - gnu-emacs-elpa/blob - packages/xpm/xpm-compose.el

   1 ;;; xpm-compose.el --- two or more buffers     -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   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.
   9
  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.
  14
  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/>.
  17
  18 ;;; Commentary:
  19
  20 ;; TODO
  21
  22 ;;; Code:
  23
  24 (require 'xpm)
  25 (require 'cl-lib)
  26
  27 (defun xpm--lines ()
  28   ;; (maybe) todo: use rectangle funcs
  29   (xpm--w/gg (w h origin flags) xpm--gg
  30     (save-excursion
  31       (goto-char origin)
  32       (cl-loop with skip = (if (memq 'intangible-sides flags)
  33                                1
  34                              4)
  35                repeat h
  36                collect (let ((p (point)))
  37                          (forward-char w)
  38                          (prog1 (buffer-substring-no-properties p (point))
  39                            (forward-char skip)))))))
  40
  41 (defun xpm--clone (src)
  42   (insert-buffer-substring src)
  43   (setq xpm--gg (xpm--copy-gg (buffer-local-value 'xpm--gg src))))
  44
  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))
  50          source populate)
  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)
  59       (unless name
  60         (goto-char (point-min))
  61         (re-search-forward "\\(\\S-+\\)\\[\\]")
  62         (rename-buffer (match-string 1)))
  63       (current-buffer))))
  64
  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."
  68   (when (characterp 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
  73                      (xpm--lines))))
  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)))))
  79         ;; do it
  80         (goto-char origin)
  81         (cl-loop with skip = (if (memq 'intangible-sides flags)
  82                                  1
  83                                4)
  84                  for line in lines
  85                  do (cl-loop
  86                      ;; this is slow and stupid
  87                      ;; todo: use ‘compare-strings’
  88                      for x below w
  89                      do (let* ((i (* x cpp))
  90                                (el (substring line i (+ i cpp))))
  91                           (if (string= px el)
  92                               (forward-char cpp)
  93                             (insert el)
  94                             (delete-char cpp))))
  95                  do (when (< (point) (point-max))
  96                       (forward-char skip)))
  97         (current-buffer)))))
  98
  99 (defun xpm-fill (px)
 100   "Fill with PX."
 101   (interactive "sPX: ")
 102   (xpm--w/gg (w h) (xpm--gate)
 103     (save-excursion
 104       (cl-loop with x = (cons 0 (1- w))
 105                for y below h
 106                do (xpm-put-points px x y)))))
 107
 108 (provide 'xpm-compose)
 109
 110 \f
 111 (defun ttn-test-xpm-compose ()
 112   (interactive)
 113   (cl-flet ((zonk (name) (let ((buf (get-buffer name)))
 114                            (when buf (kill-buffer buf)))))
 115     (mapc #'zonk '("one" "two" "zow"))
 116     ;; create
 117     (let* ((palette '((?\s . "black")   ; bg
 118                       (?#  . "green")   ; fg
 119                       (?X  . "red")
 120                       (?-  . "None")))
 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
 125         (xpm-fill ?-)
 126         (cl-flet
 127             ((vec () (let ((v (make-vector 42 nil)))
 128                        (cl-loop for i below 42
 129                                 do (aset v i (random 10)))
 130                        v)))
 131           (xpm-put-points ?\s (vec) (vec))))
 132       (cl-assert (and (bufferp one)
 133                    (bufferp two))))
 134     ;; mogrify
 135     (let* ((debug-ignored-errors nil)
 136            (one (get-buffer "one"))
 137            (two (get-buffer "two"))
 138            (zow (xpm-compose "zow" one two ?-)))
 139       (when (bufferp zow)
 140         (switch-to-buffer zow)))))
 141
 142 ;;; xpm-compose.el ends here