From 1cf425351efc8a9bee03126ebda0636e369faba1 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 17 May 2014 23:32:48 +0200 Subject: [PATCH] [xpm] Add Emacs Lisp files. * packages/xpm/xpm.el: New file. * packages/xpm/xpm-m2z.el: New file. --- packages/xpm/xpm-m2z.el | 94 +++++++++ packages/xpm/xpm.el | 419 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 513 insertions(+) create mode 100644 packages/xpm/xpm-m2z.el create mode 100644 packages/xpm/xpm.el diff --git a/packages/xpm/xpm-m2z.el b/packages/xpm/xpm-m2z.el new file mode 100644 index 000000000..73730ad03 --- /dev/null +++ b/packages/xpm/xpm-m2z.el @@ -0,0 +1,94 @@ +;;; xpm-m2z.el --- (% span 2) => 0 -*- 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 . + +;;; Commentary: + +;; Although artist.el is wonderful, it doesn't (yet) do subpixel-centered +;; circles (or ellipses). Those shapes are always rendered with an odd +;; "span", i.e., (% (- HI LO -1) 2) => 1, since the origin is *on* an +;; integral coordinate (i.e., intersection of row and column). +;; +;; This file provides funcs `xpm-m2z-ellipse' and `xpm-m2z-circle' to +;; locally rectify the current situation ("m2z" means "modulo 2 => 0"), +;; with the hope that eventually a generalization can be worked back +;; into artist.el, perhaps as a subpixel-center minor mode of some sort. + +;;; Code: + +(require 'artist) +(require 'cl-lib) + +;;;###autoload +(defun xpm-m2z-ellipse (cx cy rx ry) + "Return an ellipse with center (CX,CY) and radii RX and RY. +Both CX and CY must be non-integer, preferably +precisely half-way between integers, e.g., 13/2 => 6.5. +The ellipse is represented as a list of unique XPM coords, +with the \"span\", i.e., (- HI LO -1) of the extreme X and Y +components is equal to twice the rounded (to integer) value +of RX and RY, respectively. For example: + + (xpm-m2z-ellipse 1.5 3.5 5.8 4.2) + => list of length 20 + + min max span + X -3 6 10 + Y 0 7 8 + +The span is always an even number. As a special case, +if RX or RY is less than 1, the value is nil." + (assert (not (integerp cx))) + (assert (not (integerp cy))) + (unless (or (> 1 (abs rx)) + (> 1 (abs ry))) + (cl-flet* + ((offset (coord idx) + (- (aref coord idx) 0.5)) + (normal (coord) + ;; flip axes: artist (ROW,COL) to xpm (X,Y) + (cons + (offset coord 1) ; 1: COL -> car: X + (offset coord 0))) ; 0: ROW -> cdr: Y + (placed (origin scale n) + (truncate (+ origin (* scale n)))) + (orient (coords quadrant) + (loop with (sx . sy) = quadrant + for (x . y) in coords + collect (cons (placed cx sx x) + (placed cy sy y))))) + (delete-dups + (loop with coords = (mapcar + #'normal + (artist-ellipse-generate-quadrant + ;; Specify row first; artist.el is like that. + ;; (That's why ‘normal’ does what it does...) + ry rx)) + for quadrant ; these are in order: I-IV + in '(( 1 . 1) ; todo: "manually" remove single + (-1 . 1) ; (border point) overlaps; + (-1 . -1) ; avoid ‘delete-dups’ + ( 1 . -1)) + append (orient coords quadrant)))))) + +;;;###autoload +(defun xpm-m2z-circle (cx cy radius) + "Like `xpm-m2z-ellipse' with a shared radius RADIUS." + (xpm-m2z-ellipse cx cy radius radius)) + +(provide 'xpm-m2z) + +;;; xpm-m2z.el ends here diff --git a/packages/xpm/xpm.el b/packages/xpm/xpm.el new file mode 100644 index 000000000..c08ea33bf --- /dev/null +++ b/packages/xpm/xpm.el @@ -0,0 +1,419 @@ +;;; xpm.el --- edit XPM images -*- lexical-binding: t -*- + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; Author: Thien-Thi Nguyen +;; Maintainer: Thien-Thi Nguyen +;; 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 . + +;;; Commentary: + +;; This package makes editing XPM images easy (and maybe fun). +;; Editing is done directly on the (textual) image format, +;; for maximal cohesion w/ the Emacs Way. +;; +;; Coordinates have the form (X . Y), with X from 0 to (width-1), +;; and Y from 0 to (height-1), inclusive, in the 4th quadrant; +;; i.e., X grows left to right, Y top to bottom, origin top-left. +;; +;; (0,0) … (width-1,0) +;; ⋮ ⋮ +;; (0,height-1) … (width-1,height-1) +;; +;; In xpm.el (et al), "px" stands for "pixel", a non-empty string +;; in the external representation of the image. The px length is +;; the image's "cpp" (characters per pixel). The "palette" is a +;; set of associations between a px and its "color", which is an +;; alist with symbolic TYPE and and string CVALUE. TYPE is one of: +;; +;; c -- color (most common) +;; s -- symbolic +;; g -- grayscale +;; g4 -- four-level grayscale +;; m -- monochrome +;; +;; and CVALUE is a string, e.g., "blue" or "#0000FF". Two images +;; are "congruent" if their width, height and cpp are identical. +;; +;; This package was originally conceived for non-interactive use, +;; so its design is spartan at the core. However, we plan on +;; adding a XPM mode in a future release; see HACKING link below. +;; +;; For now, the features (w/ correspondingly-named files) are: +;; - xpm -- edit XPM images +;; - xpm-m2z -- ellipse/circle w/ fractional center +;; +;; Some things are autoloaded. Which ones? Use the source, Luke! +;; (Alternatively, just ask on help-gnu-emacs (at gnu dot org).) +;; +;; +;; See Also +;; - HACKING: +;; - Tip Jar: + +;;; Code: + +(require 'cl-lib) + +(defvar xpm-raster-inhibit-continuity-optimization nil + "Non-nil disables a heuristic in `xpm-raster' filling. +Normally, if you pass a well-formed (closed, no edge crossings) +shape to `xpm-raster', then you can ignore this variable.") + +(cl-defstruct (xpm--gg ; gathered gleanings + (:type vector) ; no ‘:named’ so no predicate + (:conc-name xpm--) + (:constructor xpm--make-gg) + (:copier xpm--copy-gg)) + (w :read-only t) (h :read-only t) (cpp :read-only t) + pinfo ; (MARKER . HASH-TABLE) + (origin :read-only t) + (y-mult :read-only t) + flags) + +(defvar xpm--gg nil + "Various bits for xpm.el (et al) internal use.") + +;;;###autoload +(defun xpm-grok (&optional simple) + "Analyze buffer and prepare internal data structures. +When called as a command, display in the echo area a +summary of image dimensions, cpp and palette. +Set buffer-local variable `xpm--gg' and return its value. +Normally, preparation includes making certain parts of +the buffer intangible. Optional arg SIMPLE inhibits that." + (interactive) + (unless (or + ;; easy + (and (boundp 'image-type) + (eq 'xpm image-type)) + ;; hard + (save-excursion + (goto-char (point-min)) + (string= "/* XPM */" + (buffer-substring-no-properties + (point) (line-end-position))))) + (error "Buffer not an XPM image")) + (when (eq 'image-mode major-mode) + (image-toggle-display)) + (let ((ht (make-hash-table :test 'equal)) + pinfo gg) + (save-excursion + (goto-char (point-min)) + (search-forward "{") + (skip-chars-forward "^\"") + (destructuring-bind (w h nc cpp &rest rest) + (read (format "(%s)" (read (current-buffer)))) + (ignore rest) ; for now + (forward-line 1) + (setq pinfo (point-marker)) + (loop repeat nc + do (let ((p (1+ (point)))) + (puthash (buffer-substring-no-properties + p (+ p cpp)) + ;; Don't bother w/ CVALUE for now. + t ht) + (forward-line 1))) + (setq pinfo (cons pinfo ht)) + (skip-chars-forward "^\"") + (forward-char 1) + (set (make-local-variable 'xpm--gg) + (setq gg (xpm--make-gg + :w w :h h :cpp cpp + :pinfo pinfo + :origin (point-marker) + :y-mult (+ 4 (* cpp w))))) + (unless simple + (let ((mod (buffer-modified-p)) + (inhibit-read-only t)) + (cl-flet + ((suppress (span &rest more) + (let ((p (point))) + (add-text-properties + (- p span) p (list* 'intangible t + more))))) + (suppress 1) + (loop repeat h + do (progn (forward-char (+ 4 (* w cpp))) + (suppress 4))) + (suppress 2 'display "\n") + (push 'intangible-sides (xpm--flags gg))) + (set-buffer-modified-p mod))) + (when (called-interactively-p 'interactive) + (message "%dx%d, %d cpp, %d colors in palette" + w h cpp (hash-table-count ht))))) + gg)) + +(defun xpm--gate () + (or xpm--gg + (xpm-grok) + (error "Sorry, xpm confused"))) + +(cl-defmacro xpm--w/gg (names from &body body) + (declare (indent 2)) + `(let* ((gg ,from) + ,@(mapcar (lambda (name) + `(,name (,(intern (format "xpm--%s" name)) + gg))) + `,names)) + ,@body)) + +;;;###autoload +(defun xpm-generate-buffer (name width height cpp palette) + "Return a new buffer in XPM image format. +NAME is the buffer and XPM name. For best interoperation +with other programs, NAME should be a valid C identifier. +WIDTH, HEIGHT and CPP are integers that specify the image +width, height and characters/pixel, respectively. + +PALETTE is an alist ((PX . COLOR) ...), where PX is either +a character or string of length CPP, and COLOR is a string. +If COLOR includes a space, it is included directly, +otherwise it is automatically prefixed with \"c \". + +For example, to produce fragment: + + \"X c blue\", + \"Y s border c green\", + +you can specify PALETTE as: + + ((?X . \"blue\") (?Y . \"s border c green\")) + +This example presumes CPP is 1." + (let ((buf (generate-new-buffer name))) + (with-current-buffer buf + (buffer-disable-undo) + (cl-flet + ((yep (s &rest args) + (insert (apply 'format s args) "\n"))) + (yep "/* XPM */") + (yep "static char * %s[] = {" name) + (yep "\"%d %d %d %d\"," width height (length palette) cpp) + (loop for (px . color) in palette + do (yep "\"%s %s\"," + (if (characterp px) + (string px) + px) + (if (string-match " " color) + color + (concat "c " color)))) + (loop with s = (format "%S,\n" (make-string (* cpp width) 32)) + repeat height + do (insert s)) + (delete-char -2) + (yep "};") + (xpm-grok t))) + buf)) + +(defun xpm-put-points (px x y) + "Place PX at coordinate(s) (X,Y). + +If both X and Y are vectors of length N, then place N points +using the pairwise vector elements. If one of X or Y is a vector +of length N, then pair its elements with the other integer component +and place N points. + +If one of X or Y is a pair (LOW . HIGH), take it to be equivalent +t specfiying a vector [LOW ... HIGH]. For example, (3 . 8) is +equivalent to [3 4 5 6 7 8]. If one component is a pair, the +other must be an integer -- the case where both X and Y are pairs +is not supported. + +Silently ignore out-of-range coordinates." + (xpm--w/gg (w h cpp origin y-mult) (xpm--gate) + (when (and (stringp px) (= 1 cpp)) + (setq px (aref px 0))) + (cl-flet* + ((out (col row) + (or (> 0 col) (<= w col) + (> 0 row) (<= h row))) + (pos (col row) + (goto-char (+ origin (* cpp col) (* y-mult row)))) + (jam (col row len) + (pos col row) + (insert-char px len) + (delete-char len)) + (rep (col row len) + (pos col row) + (if (= 1 cpp) + (insert-char px len) + (loop repeat len do (insert px))) + (delete-char (* cpp len))) + (zow (col row) + (unless (out col row) + (rep col row 1)))) + (pcase (cons (type-of x) (type-of y)) + (`(cons . integer) (let* ((beg (max 0 (car x))) + (end (min (1- w) (cdr x))) + (len (- end beg -1))) + (unless (or (> 1 len) + (out beg y)) + (if (< 1 cpp) + ;; general + (rep beg y len) + ;; fast(er) path + (when (stringp px) + (setq px (aref px 0))) + (jam beg y len))))) + (`(integer . cons) (loop for two from (car y) to (cdr y) + do (zow x two))) + (`(vector . integer) (loop for one across x + do (zow one y))) + (`(integer . vector) (loop for two across y + do (zow x two))) + (`(vector . vector) (loop for one across x + for two across y + do (zow one two))) + (`(integer . integer) (zow x y)) + (_ (error "Bad coordinates: X %S, Y %S" + x y)))))) + +(defun xpm-raster (form edge &optional fill) + "Rasterize FORM with EDGE pixel (character or string). +FORM is a list of coordinates that comprise a closed shape. +Optional arg FILL specifies a fill pixel, or t to fill with EDGE. + +If FORM is not closed or has inopportune vertical-facing +concavities, filling might give bad results. For those cases, +see variable `xpm-raster-inhibit-continuity-optimization'." + (when (eq t fill) + (setq fill edge)) + (xpm--w/gg (h) (xpm--gate) + (let* ((v (make-vector h nil)) + (x-min (caar form)) ; (maybe) todo: xpm--bb + (x-max x-min) + (y-min (cdar form)) + (y-max y-min) + (use-in-map (not xpm-raster-inhibit-continuity-optimization)) + ;; These are bool-vectors to keep track of both internal + ;; (filled and its "next" (double-buffering)) and external + ;; state, on a line-by-line basis. + int nin + ext) + (loop for (x . y) in form + do (setq x-min (min x-min x) + x-max (max x-max x) + y-min (min y-min y) + y-max (max y-max y)) + unless (or (> 0 y) + (<= h y)) + do (push x (aref v y))) + (cl-flet + ((span (lo hi) + (- hi lo -1)) + (norm (n) + (- n x-min)) + (rset (bv start len value) + (loop for i from start repeat len + do (aset bv i value))) + (scan (bv start len yes no) + (loop for i from start repeat len + when (aref bv i) + return yes + finally return no))) + (setq int (make-bool-vector (span x-min x-max) nil) + nin (make-bool-vector (span x-min x-max) nil) + ext (make-bool-vector (span x-min x-max) t)) + (loop + with (in-map-ok + in-map) + for y below h + for unsorted across v + when unsorted + do (loop + with ls = (sort unsorted '>) + with acc = (list (car ls)) + for maybe in (cdr ls) + do (let* ((was (car acc)) + (already (consp was))) + (cond ((/= (1- (if already + (car was) + was)) + maybe) + (push maybe acc)) + (already + (setcar was maybe)) + (t + (setcar acc (cons maybe was))))) + finally do + (when fill + (let ((was (length in-map)) + (now (length acc))) + (unless (setq in-map-ok + (and (= was now) + ;; heuristic: Avoid being fooled + ;; by simulataneous crossings. + (cl-evenp was))) + (setq in-map (make-bool-vector now nil))))) + finally do + (loop + with (x rangep beg nx end len nb in) + for gap from 0 + while acc + do (setq x (pop acc)) + do (xpm-put-points edge x y) + do (when fill + (setq rangep (consp x)) + (when (zerop gap) + (rset ext 0 (norm (if rangep + (car x) + x)) + t)) + (if rangep + (destructuring-bind (b . e) x + (rset ext (norm b) (span b e) nil)) + (aset ext (norm x) nil)) + (when acc + (setq beg (1+ (if rangep + (cdr x) + x)) + nx (car acc) + end (1- (if (consp nx) + (car nx) + nx)) + len (span beg end) + nb (norm beg) + in (cond ((and use-in-map in-map-ok) + (aref in-map gap)) + (in (scan int nb len t nil)) + (t (scan ext nb len nil t)))) + (unless in-map-ok + (aset in-map gap in)) + (if (not in) + (rset ext nb len t) + (rset nin nb len t) + (xpm-put-points fill (cons beg end) y)))) + finally do (when fill + (rotatef int nin) + (fillarray nin nil))))))))) + +(defun xpm-as-xpm (&rest props) + "Return the XPM image (via `create-image') of the buffer. +PROPS are additional image properties to place on +the new XPM. See info node `(elisp) XPM Images'." + (apply 'create-image (buffer-substring-no-properties + (point-min) (point-max)) + 'xpm t props)) + +(defun xpm-finish (&rest props) + "Like `xpm-as-xpm', but also kill the buffer afterwards." + (prog1 (apply 'xpm-as-xpm props) + (kill-buffer nil))) + +(provide 'xpm) + +;;; xpm.el ends here -- 2.39.2