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 ;; Normally, lines are drawn with the `LIGHT' weight.  If you set var
  62 ;; `aa2u-uniform-weight' to symbol `HEAVY', you will see, instead:
  63 ;;
  64 ;;   ┏━━━━━━━━━━━━━━━┓
  65 ;;   ┃               ┃
  66 ;;   ┃       ┏━━━━━━━╋━━┓
  67 ;;   ┃       ┃       ┃  ┃
  68 ;;   ┃       ┃       ┃  ┃
  69 ;;   ┃       ┃       ┃  ┃
  70 ;;   ┗━━━━━━━╋━━━━━━━┛  ┃
  71 ;;           ┃          ┃
  72 ;;           ┃          ┃
  73 ;;           ┃          ┃
  74 ;;           ┗━━━━━━━━━━┛
  75 ;;
  76 ;;
  77 ;; See Also
  78 ;; - HACKING: <http://git.sv.gnu.org/cgit/emacs/elpa.git/tree/packages/ascii-art-to-unicode/HACKING>
  79 ;; - Tip Jar: <http://www.gnuvola.org/software/aa2u/>
  80
  81 ;;; Code:
  82
  83 (require 'cl-lib)
  84 (require 'pcase)
  85
  86 (defvar aa2u-uniform-weight 'LIGHT
  87   "A symbol, either `LIGHT' or `HEAVY'.
  88 This specifies the weight of all the lines.")
  89
  90 ;;;---------------------------------------------------------------------------
  91 ;;; support
  92
  93 (defun aa2u-ucs-bd-uniform-name (&rest components)
  94   "Return a string naming UCS char w/ WEIGHT and COMPONENTS.
  95 The string begins with \"BOX DRAWINGS\"; followed by the weight
  96 as per variable `aa2u-uniform-weight', followed by COMPONENTS,
  97 a list of one or two symbols from the set:
  98
  99   VERTICAL
 100   HORIZONTAL
 101   DOWN
 102   UP
 103   RIGHT
 104   LEFT
 105
 106 If of length two, the first element in COMPONENTS should be
 107 the \"Y-axis\" (VERTICAL, DOWN, UP).  In that case, the returned
 108 string includes \"AND\" between the elements of COMPONENTS.
 109
 110 Lastly, all words are separated by space (U+20)."
 111   (format "BOX DRAWINGS %s %s"
 112           aa2u-uniform-weight
 113           (mapconcat 'symbol-name components
 114                      " AND ")))
 115
 116 (defun aa2u-1c (stringifier &rest components)
 117   "Apply STRINGIFIER to COMPONENTS; return the UCS char w/ this name.
 118 The char is a string (of length one), with two properties:
 119
 120   aa2u-stringifier
 121   aa2u-components
 122
 123 Their values are STRINGIFIER and COMPONENTS, respectively."
 124   (let ((s (string (cdr (assoc-string (apply stringifier components)
 125                                       (ucs-names))))))
 126     (propertize s
 127                 'aa2u-stringifier stringifier
 128                 'aa2u-components components)))
 129
 130 (defun aa2u-phase-1 ()
 131   (goto-char (point-min))
 132   (let ((vert (aa2u-1c 'aa2u-ucs-bd-uniform-name 'VERTICAL)))
 133     (while (search-forward "|" nil t)
 134       (replace-match vert t t)))
 135   (goto-char (point-min))
 136   (let ((horz (aa2u-1c 'aa2u-ucs-bd-uniform-name 'HORIZONTAL)))
 137     (while (search-forward "-" nil t)
 138       (replace-match horz t t))))
 139
 140 (defun aa2u-replacement (pos)
 141   (let ((cc (- pos (line-beginning-position))))
 142     (cl-flet*
 143         ((ok (name pos)
 144              (when (or
 145                     ;; Infer LIGHTness between "snug" ‘?+’es.
 146                     ;;              |
 147                     ;;  +-----------++--+   +
 148                     ;;  | somewhere ++--+---+-+----+
 149                     ;;  +-+---------+ nowhere |+--+
 150                     ;;    +         +---------++
 151                     ;;              |      +---|
 152                     (eq ?+ (char-after pos))
 153                     ;; Require properly directional neighborliness.
 154                     (memq (case name
 155                             ((UP DOWN)    'VERTICAL)
 156                             ((LEFT RIGHT) 'HORIZONTAL))
 157                           (get-text-property pos 'aa2u-components)))
 158                name))
 159          (v (name dir) (let ((bol (line-beginning-position dir))
 160                              (eol (line-end-position dir)))
 161                          (when (< cc (- eol bol))
 162                            (ok name (+ bol cc)))))
 163          (h (name dir) (let ((bol (line-beginning-position))
 164                              (eol (line-end-position))
 165                              (pos (+ pos dir)))
 166                          (unless (or (> bol pos)
 167                                      (<= eol pos))
 168                            (ok name pos))))
 169          (two-p (ls) (= 2 (length ls)))
 170          (just (&rest args) (delq nil args)))
 171       (apply 'aa2u-1c
 172              'aa2u-ucs-bd-uniform-name
 173              (just (pcase (just (v 'UP   0)
 174                                 (v 'DOWN 2))
 175                      ((pred two-p) 'VERTICAL)
 176                      (`(,vc)        vc)
 177                      (_             nil))
 178                    (pcase (just (h 'LEFT  -1)
 179                                 (h 'RIGHT  1))
 180                      ((pred two-p) 'HORIZONTAL)
 181                      (`(,hc)        hc)
 182                      (_             nil)))))))
 183
 184 (defun aa2u-phase-2 ()
 185   (goto-char (point-min))
 186   (let (changes)
 187     ;; (phase 2.1 -- what WOULD change)
 188     ;; This is for the benefit of ‘aa2u-replacement ok’, which
 189     ;; otherwise (monolithic phase 2) would need to convert the
 190     ;; "properly directional neighborliness" impl from a simple
 191     ;; ‘memq’ to an ‘intersction’.
 192     (while (search-forward "+" nil t)
 193       (let ((p (point)))
 194         (push (cons p (or (aa2u-replacement (1- p))
 195                           "?"))
 196               changes)))
 197     ;; (phase 2.2 -- apply changes)
 198     (dolist (ch changes)
 199       (goto-char (car ch))
 200       (delete-char -1)
 201       (insert (cdr ch)))))
 202
 203 (defun aa2u-phase-3 ()
 204   (remove-text-properties (point-min) (point-max)
 205                           (list 'aa2u-stringifier nil
 206                                 'aa2u-components nil)))
 207
 208 ;;;---------------------------------------------------------------------------
 209 ;;; command
 210
 211 ;;;###autoload
 212 (defun aa2u (beg end &optional interactive)
 213   "Convert simple ASCII art line drawings to Unicode.
 214 Specifically, perform the following replacements:
 215
 216   - (hyphen)          BOX DRAWINGS LIGHT HORIZONTAL
 217   | (vertical bar)    BOX DRAWINGS LIGHT VERTICAL
 218   + (plus)            (one of)
 219                       BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
 220                       BOX DRAWINGS LIGHT DOWN AND RIGHT
 221                       BOX DRAWINGS LIGHT DOWN AND LEFT
 222                       BOX DRAWINGS LIGHT UP AND RIGHT
 223                       BOX DRAWINGS LIGHT UP AND LEFT
 224                       BOX DRAWINGS LIGHT VERTICAL AND RIGHT
 225                       BOX DRAWINGS LIGHT VERTICAL AND LEFT
 226                       BOX DRAWINGS LIGHT UP AND HORIZONTAL
 227                       BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
 228                       BOX DRAWINGS LIGHT UP
 229                       BOX DRAWINGS LIGHT DOWN
 230                       BOX DRAWINGS LIGHT LEFT
 231                       BOX DRAWINGS LIGHT RIGHT
 232                       QUESTION MARK
 233
 234 More precisely, hyphen and vertical bar are substituted unconditionally,
 235 first, and plus is substituted with a character depending on its north,
 236 south, east and west neighbors.
 237
 238 NB: Actually, `aa2u' can also use \"HEAVY\" instead of \"LIGHT\",
 239 depending on the value of variable `aa2u-uniform-weight'.
 240
 241 This command operates on either the active region,
 242 or the accessible portion otherwise."
 243   (interactive "r\np")
 244   ;; This weirdness, along w/ the undocumented "p" in the ‘interactive’
 245   ;; form, is to allow ‘M-x aa2u’ (interactive invocation) w/ no region
 246   ;; selected to default to the accessible portion (as documented), which
 247   ;; was the norm in ascii-art-to-unicode.el prior to 1.5.  A bugfix,
 248   ;; essentially.  This is ugly, unfortunately -- is there a better way?!
 249   (when (and interactive (not (region-active-p)))
 250     (setq beg (point-min)
 251           end (point-max)))
 252   (save-excursion
 253     (save-restriction
 254       (widen)
 255       (narrow-to-region beg end)
 256       (aa2u-phase-1)
 257       (aa2u-phase-2)
 258       (aa2u-phase-3))))
 259
 260 ;;;---------------------------------------------------------------------------
 261 ;;; that's it
 262
 263 (provide 'ascii-art-to-unicode)
 264
 265 ;;; ascii-art-to-unicode.el ends here