code.delx.au - gnu-emacs-elpa/blob - packages/ascii-art-to-unicode/ascii-art-to-unicode.el

   1 ;;; ascii-art-to-unicode.el --- a small artist adjunct -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
   6 ;; Version: 1.6
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; The command `aa2u' converts simple ASCII art line drawings in
  24 ;; the {active,accessible} region of the current buffer to Unicode.
  25 ;;
  26 ;; Example use case:
  27 ;; - M-x artist-mode RET
  28 ;; - C-c C-a r               ; artist-select-op-rectangle
  29 ;; - (draw two rectangles)
  30 ;;
  31 ;;   +---------------+
  32 ;;   |               |
  33 ;;   |       +-------+--+
  34 ;;   |       |       |  |
  35 ;;   |       |       |  |
  36 ;;   |       |       |  |
  37 ;;   +-------+-------+  |
  38 ;;           |          |
  39 ;;           |          |
  40 ;;           |          |
  41 ;;           +----------+
  42 ;;
  43 ;; - C-c C-c                 ; artist-mode-off (optional)
  44 ;; - C-x n n                 ; narrow-to-region
  45 ;; - M-x aa2u RET
  46 ;;
  47 ;;   ┌───────────────┐
  48 ;;   │               │
  49 ;;   │       ┌───────┼──┐
  50 ;;   │       │       │  │
  51 ;;   │       │       │  │
  52 ;;   │       │       │  │
  53 ;;   └───────┼───────┘  │
  54 ;;           │          │
  55 ;;           │          │
  56 ;;           │          │
  57 ;;           └──────────┘
  58 ;;
  59 ;; Much easier on the eyes now!
  60 ;;
  61 ;;
  62 ;; See Also
  63 ;; - HACKING: <http://git.sv.gnu.org/cgit/emacs/elpa.git/tree/packages/ascii-art-to-unicode/HACKING>
  64 ;; - Tip Jar: <http://www.gnuvola.org/software/aa2u/>
  65
  66 ;;; Code:
  67
  68 (require 'cl-lib)
  69 (require 'pcase)
  70
  71 ;;;---------------------------------------------------------------------------
  72 ;;; support
  73
  74 (defun aa2u-ucs-bd-uniform-name (weight &rest components)
  75   "Return a string naming UCS char w/ WEIGHT and COMPONENTS.
  76 The string begins with \"BOX DRAWINGS\"; followed by WEIGHT,
  77 a symbol from the set:
  78
  79   HEAVY
  80   LIGHT
  81
  82 followed by COMPONENTS, a list of one or two symbols from the set:
  83
  84   VERTICAL
  85   HORIZONTAL
  86   DOWN
  87   UP
  88   RIGHT
  89   LEFT
  90
  91 If of length two, the first element in COMPONENTS should be
  92 the \"Y-axis\" (VERTICAL, DOWN, UP).  In that case, the returned
  93 string includes \"AND\" between the elements of COMPONENTS.
  94
  95 Lastly, all words are separated by space (U+20)."
  96   (format "BOX DRAWINGS %s %s"
  97           weight
  98           (mapconcat 'symbol-name components
  99                      " AND ")))
 100
 101 (defun aa2u-1c (stringifier &rest components)
 102   "Apply STRINGIFIER to COMPONENTS; return the UCS char w/ this name.
 103 The char is a string (of length one), with two properties:
 104
 105   aa2u-stringifier
 106   aa2u-components
 107
 108 Their values are STRINGIFIER and COMPONENTS, respectively."
 109   (let ((s (string (cdr (assoc-string (apply stringifier components)
 110                                       (ucs-names))))))
 111     (propertize s
 112                 'aa2u-stringifier stringifier
 113                 'aa2u-components components)))
 114
 115 (defun aa2u-phase-1 ()
 116   (goto-char (point-min))
 117   (let ((vert (aa2u-1c 'aa2u-ucs-bd-uniform-name 'LIGHT 'VERTICAL)))
 118     (while (search-forward "|" nil t)
 119       (replace-match vert t t)))
 120   (goto-char (point-min))
 121   (let ((horz (aa2u-1c 'aa2u-ucs-bd-uniform-name 'LIGHT 'HORIZONTAL)))
 122     (while (search-forward "-" nil t)
 123       (replace-match horz t t))))
 124
 125 (defun aa2u-replacement (pos)
 126   (let ((cc (- pos (line-beginning-position))))
 127     (cl-flet*
 128         ((ok (name pos)
 129              (when (or
 130                     ;; Infer LIGHTness between "snug" ‘?+’es.
 131                     ;;              |
 132                     ;;  +-----------++--+   +
 133                     ;;  | somewhere ++--+---+-+----+
 134                     ;;  +-+---------+ nowhere |+--+
 135                     ;;    +         +---------++
 136                     ;;              |      +---|
 137                     (eq ?+ (char-after pos))
 138                     ;; Require properly directional neighborliness.
 139                     (memq (case name
 140                             ((UP DOWN)    'VERTICAL)
 141                             ((LEFT RIGHT) 'HORIZONTAL))
 142                           (get-text-property pos 'aa2u-components)))
 143                name))
 144          (v (name dir) (let ((bol (line-beginning-position dir))
 145                              (eol (line-end-position dir)))
 146                          (when (< cc (- eol bol))
 147                            (ok name (+ bol cc)))))
 148          (h (name dir) (let ((bol (line-beginning-position))
 149                              (eol (line-end-position))
 150                              (pos (+ pos dir)))
 151                          (unless (or (> bol pos)
 152                                      (<= eol pos))
 153                            (ok name pos))))
 154          (two-p (ls) (= 2 (length ls)))
 155          (just (&rest args) (delq nil args)))
 156       (apply 'aa2u-1c
 157              'aa2u-ucs-bd-uniform-name
 158              'LIGHT
 159              (just (pcase (just (v 'UP   0)
 160                                 (v 'DOWN 2))
 161                      ((pred two-p) 'VERTICAL)
 162                      (`(,vc)        vc)
 163                      (_             nil))
 164                    (pcase (just (h 'LEFT  -1)
 165                                 (h 'RIGHT  1))
 166                      ((pred two-p) 'HORIZONTAL)
 167                      (`(,hc)        hc)
 168                      (_             nil)))))))
 169
 170 (defun aa2u-phase-2 ()
 171   (goto-char (point-min))
 172   (let (changes)
 173     ;; (phase 2.1 -- what WOULD change)
 174     ;; This is for the benefit of ‘aa2u-replacement ok’, which
 175     ;; otherwise (monolithic phase 2) would need to convert the
 176     ;; "properly directional neighborliness" impl from a simple
 177     ;; ‘memq’ to an ‘intersction’.
 178     (while (search-forward "+" nil t)
 179       (let ((p (point)))
 180         (push (cons p (or (aa2u-replacement (1- p))
 181                           "?"))
 182               changes)))
 183     ;; (phase 2.2 -- apply changes)
 184     (dolist (ch changes)
 185       (goto-char (car ch))
 186       (delete-char -1)
 187       (insert (cdr ch)))))
 188
 189 (defun aa2u-phase-3 ()
 190   (remove-text-properties (point-min) (point-max)
 191                           (list 'aa2u-stringifier nil
 192                                 'aa2u-components nil)))
 193
 194 ;;;---------------------------------------------------------------------------
 195 ;;; command
 196
 197 ;;;###autoload
 198 (defun aa2u (beg end &optional interactive)
 199   "Convert simple ASCII art line drawings to Unicode.
 200 Specifically, perform the following replacements:
 201
 202   - (hyphen)          BOX DRAWINGS LIGHT HORIZONTAL
 203   | (vertical bar)    BOX DRAWINGS LIGHT VERTICAL
 204   + (plus)            (one of)
 205                       BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
 206                       BOX DRAWINGS LIGHT DOWN AND RIGHT
 207                       BOX DRAWINGS LIGHT DOWN AND LEFT
 208                       BOX DRAWINGS LIGHT UP AND RIGHT
 209                       BOX DRAWINGS LIGHT UP AND LEFT
 210                       BOX DRAWINGS LIGHT VERTICAL AND RIGHT
 211                       BOX DRAWINGS LIGHT VERTICAL AND LEFT
 212                       BOX DRAWINGS LIGHT UP AND HORIZONTAL
 213                       BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
 214                       BOX DRAWINGS LIGHT UP
 215                       BOX DRAWINGS LIGHT DOWN
 216                       BOX DRAWINGS LIGHT LEFT
 217                       BOX DRAWINGS LIGHT RIGHT
 218                       QUESTION MARK
 219
 220 More precisely, hyphen and vertical bar are substituted unconditionally,
 221 first, and plus is substituted with a character depending on its north,
 222 south, east and west neighbors.
 223
 224 This command operates on either the active region,
 225 or the accessible portion otherwise."
 226   (interactive "r\np")
 227   ;; This weirdness, along w/ the undocumented "p" in the ‘interactive’
 228   ;; form, is to allow ‘M-x aa2u’ (interactive invocation) w/ no region
 229   ;; selected to default to the accessible portion (as documented), which
 230   ;; was the norm in ascii-art-to-unicode.el prior to 1.5.  A bugfix,
 231   ;; essentially.  This is ugly, unfortunately -- is there a better way?!
 232   (when (and interactive (not (region-active-p)))
 233     (setq beg (point-min)
 234           end (point-max)))
 235   (save-excursion
 236     (save-restriction
 237       (widen)
 238       (narrow-to-region beg end)
 239       (aa2u-phase-1)
 240       (aa2u-phase-2)
 241       (aa2u-phase-3))))
 242
 243 ;;;---------------------------------------------------------------------------
 244 ;;; that's it
 245
 246 (provide 'ascii-art-to-unicode)
 247
 248 ;;; ascii-art-to-unicode.el ends here