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 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
   7 ;; Version: 1.9
   8 ;; Keywords: ascii, unicode, box-drawing
   9 ;; URL: http://www.gnuvola.org/software/aa2u/
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; The command `aa2u' converts simple ASCII art line drawings in
  27 ;; the {active,accessible} region of the current buffer to Unicode.
  28 ;; Command `aa2u-rectangle' is like `aa2u', but works on rectangles.
  29 ;;
  30 ;; Example use case:
  31 ;; - M-x artist-mode RET
  32 ;; - C-c C-a r               ; artist-select-op-rectangle
  33 ;; - (draw two rectangles)
  34 ;;
  35 ;;   +---------------+
  36 ;;   |               |
  37 ;;   |       +-------+--+
  38 ;;   |       |       |  |
  39 ;;   |       |       |  |
  40 ;;   |       |       |  |
  41 ;;   +-------+-------+  |
  42 ;;           |          |
  43 ;;           |          |
  44 ;;           |          |
  45 ;;           +----------+
  46 ;;
  47 ;; - C-c C-c                 ; artist-mode-off (optional)
  48 ;; - C-x n n                 ; narrow-to-region
  49 ;; - M-x aa2u RET
  50 ;;
  51 ;;   ┌───────────────┐
  52 ;;   │               │
  53 ;;   │       ┌───────┼──┐
  54 ;;   │       │       │  │
  55 ;;   │       │       │  │
  56 ;;   │       │       │  │
  57 ;;   └───────┼───────┘  │
  58 ;;           │          │
  59 ;;           │          │
  60 ;;           │          │
  61 ;;           └──────────┘
  62 ;;
  63 ;; Much easier on the eyes now!
  64 ;;
  65 ;; Normally, lines are drawn with the `LIGHT' weight.  If you set var
  66 ;; `aa2u-uniform-weight' to symbol `HEAVY', you will see, instead:
  67 ;;
  68 ;;   ┏━━━━━━━━━━━━━━━┓
  69 ;;   ┃               ┃
  70 ;;   ┃       ┏━━━━━━━╋━━┓
  71 ;;   ┃       ┃       ┃  ┃
  72 ;;   ┃       ┃       ┃  ┃
  73 ;;   ┃       ┃       ┃  ┃
  74 ;;   ┗━━━━━━━╋━━━━━━━┛  ┃
  75 ;;           ┃          ┃
  76 ;;           ┃          ┃
  77 ;;           ┃          ┃
  78 ;;           ┗━━━━━━━━━━┛
  79 ;;
  80 ;; To protect particular ‘|’, ‘-’ or ‘+’ characters from conversion,
  81 ;; you can set the property `aa2u-text' on that text with command
  82 ;; `aa2u-mark-as-text'.  A prefix arg clears the property, instead.
  83 ;; (You can use `describe-text-properties' to check.)  For example:
  84 ;;
  85 ;;      ┌───────────────────┐
  86 ;;      │                   │
  87 ;;      │ |\/|              │
  88 ;;      │ `Oo'   --Oop Ack! │
  89 ;;      │  ^&-MM.           │
  90 ;;      │                   │
  91 ;;      └─────────┬─────────┘
  92 ;;                │
  93 ;;            """""""""
  94 ;;
  95 ;; Command `aa2u-mark-rectangle-as-text' is similar, for rectangles.
  96 ;;
  97 ;; Tip: For best results, you should make sure all the tab characaters
  98 ;; are converted to spaces.  See: `untabify', `indent-tabs-mode'.
  99
 100 ;;; Code:
 101
 102 (require 'cl-lib)
 103 (require 'pcase)
 104
 105 (autoload 'apply-on-rectangle "rect")
 106
 107 (defvar aa2u-uniform-weight 'LIGHT
 108   "A symbol, either `LIGHT' or `HEAVY'.
 109 This specifies the weight of all the lines.")
 110
 111 ;;;---------------------------------------------------------------------------
 112 ;;; support
 113
 114 (defsubst aa2u--text-p (pos)
 115   (get-text-property pos 'aa2u-text))
 116
 117 (defun aa2u-ucs-bd-uniform-name (&rest components)
 118   "Return a string naming UCS char w/ WEIGHT and COMPONENTS.
 119 The string begins with \"BOX DRAWINGS\"; followed by the weight
 120 as per variable `aa2u-uniform-weight', followed by COMPONENTS,
 121 a list of one or two symbols from the set:
 122
 123   VERTICAL
 124   HORIZONTAL
 125   DOWN
 126   UP
 127   RIGHT
 128   LEFT
 129
 130 If of length two, the first element in COMPONENTS should be
 131 the \"Y-axis\" (VERTICAL, DOWN, UP).  In that case, the returned
 132 string includes \"AND\" between the elements of COMPONENTS.
 133
 134 Lastly, all words are separated by space (U+20)."
 135   (format "BOX DRAWINGS %s %s"
 136           aa2u-uniform-weight
 137           (mapconcat 'symbol-name components
 138                      " AND ")))
 139
 140 (defun aa2u-1c (stringifier &rest components)
 141   "Apply STRINGIFIER to COMPONENTS; return the UCS char w/ this name.
 142 The char is a string (of length one), with two properties:
 143
 144   aa2u-stringifier
 145   aa2u-components
 146
 147 Their values are STRINGIFIER and COMPONENTS, respectively."
 148   (let ((s (string (cdr (assoc-string (apply stringifier components)
 149                                       (ucs-names))))))
 150     (propertize s
 151                 'aa2u-stringifier stringifier
 152                 'aa2u-components components)))
 153
 154 (defun aa2u-phase-1 ()
 155   (cl-flet
 156       ((gsr (was name)
 157             (goto-char (point-min))
 158             (let ((now (aa2u-1c 'aa2u-ucs-bd-uniform-name name)))
 159               (while (search-forward was nil t)
 160                 (unless (aa2u--text-p (match-beginning 0))
 161                   (replace-match now t t))))))
 162     (gsr "|" 'VERTICAL)
 163     (gsr "-" 'HORIZONTAL)))
 164
 165 (defun aa2u-replacement (pos)
 166   (let ((cc (- pos (line-beginning-position))))
 167     (cl-flet*
 168         ((ok (name pos)
 169              (when (or
 170                     ;; Infer LIGHTness between "snug" ‘?+’es.
 171                     ;;              |
 172                     ;;  +-----------++--+   +
 173                     ;;  | somewhere ++--+---+-+----+
 174                     ;;  +-+---------+ nowhere |+--+
 175                     ;;    +         +---------++
 176                     ;;              |      +---|
 177                     (eq ?+ (char-after pos))
 178                     ;; Require properly directional neighborliness.
 179                     (memq (cl-case name
 180                             ((UP DOWN)    'VERTICAL)
 181                             ((LEFT RIGHT) 'HORIZONTAL))
 182                           (get-text-property pos 'aa2u-components)))
 183                name))
 184          (v (name dir) (let ((bol (line-beginning-position dir))
 185                              (eol (line-end-position dir)))
 186                          (when (< cc (- eol bol))
 187                            (ok name (+ bol cc)))))
 188          (h (name dir) (let ((bol (line-beginning-position))
 189                              (eol (line-end-position))
 190                              (pos (+ pos dir)))
 191                          (unless (or (> bol pos)
 192                                      (<= eol pos))
 193                            (ok name pos))))
 194          (two-p (ls) (= 2 (length ls)))
 195          (just (&rest args) (delq nil args)))
 196       (apply 'aa2u-1c
 197              'aa2u-ucs-bd-uniform-name
 198              (just (pcase (just (v 'UP   0)
 199                                 (v 'DOWN 2))
 200                      ((pred two-p) 'VERTICAL)
 201                      (`(,vc)        vc)
 202                      (_             nil))
 203                    (pcase (just (h 'LEFT  -1)
 204                                 (h 'RIGHT  1))
 205                      ((pred two-p) 'HORIZONTAL)
 206                      (`(,hc)        hc)
 207                      (_             nil)))))))
 208
 209 (defun aa2u-phase-2 ()
 210   (goto-char (point-min))
 211   (let (changes)
 212     ;; (phase 2.1 -- what WOULD change)
 213     ;; This is for the benefit of ‘aa2u-replacement ok’, which
 214     ;; otherwise (monolithic phase 2) would need to convert the
 215     ;; "properly directional neighborliness" impl from a simple
 216     ;; ‘memq’ to an ‘intersction’.
 217     (while (search-forward "+" nil t)
 218       (let ((p (point)))
 219         (unless (aa2u--text-p (1- p))
 220           (push (cons p (or (aa2u-replacement (1- p))
 221                             "?"))
 222                 changes))))
 223     ;; (phase 2.2 -- apply changes)
 224     (dolist (ch changes)
 225       (goto-char (car ch))
 226       (delete-char -1)
 227       (insert (cdr ch)))))
 228
 229 (defun aa2u-phase-3 ()
 230   (remove-text-properties (point-min) (point-max)
 231                           (list 'aa2u-stringifier nil
 232                                 'aa2u-components nil)))
 233
 234 ;;;---------------------------------------------------------------------------
 235 ;;; commands
 236
 237 ;;;###autoload
 238 (defun aa2u (beg end &optional interactive)
 239   "Convert simple ASCII art line drawings to Unicode.
 240 Specifically, perform the following replacements:
 241
 242   - (hyphen)          BOX DRAWINGS LIGHT HORIZONTAL
 243   | (vertical bar)    BOX DRAWINGS LIGHT VERTICAL
 244   + (plus)            (one of)
 245                       BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
 246                       BOX DRAWINGS LIGHT DOWN AND RIGHT
 247                       BOX DRAWINGS LIGHT DOWN AND LEFT
 248                       BOX DRAWINGS LIGHT UP AND RIGHT
 249                       BOX DRAWINGS LIGHT UP AND LEFT
 250                       BOX DRAWINGS LIGHT VERTICAL AND RIGHT
 251                       BOX DRAWINGS LIGHT VERTICAL AND LEFT
 252                       BOX DRAWINGS LIGHT UP AND HORIZONTAL
 253                       BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
 254                       BOX DRAWINGS LIGHT UP
 255                       BOX DRAWINGS LIGHT DOWN
 256                       BOX DRAWINGS LIGHT LEFT
 257                       BOX DRAWINGS LIGHT RIGHT
 258                       QUESTION MARK
 259
 260 More precisely, hyphen and vertical bar are substituted unconditionally,
 261 first, and plus is substituted with a character depending on its north,
 262 south, east and west neighbors.
 263
 264 NB: Actually, `aa2u' can also use \"HEAVY\" instead of \"LIGHT\",
 265 depending on the value of variable `aa2u-uniform-weight'.
 266
 267 This command operates on either the active region,
 268 or the accessible portion otherwise."
 269   (interactive "r\np")
 270   ;; This weirdness, along w/ the undocumented "p" in the ‘interactive’
 271   ;; form, is to allow ‘M-x aa2u’ (interactive invocation) w/ no region
 272   ;; selected to default to the accessible portion (as documented), which
 273   ;; was the norm in ascii-art-to-unicode.el prior to 1.5.  A bugfix,
 274   ;; essentially.  This is ugly, unfortunately -- is there a better way?!
 275   (when (and interactive (not (region-active-p)))
 276     (setq beg (point-min)
 277           end (point-max)))
 278   (save-excursion
 279     (save-restriction
 280       (widen)
 281       (narrow-to-region beg end)
 282       (aa2u-phase-1)
 283       (aa2u-phase-2)
 284       (aa2u-phase-3))))
 285
 286 ;;;###autoload
 287 (defun aa2u-rectangle (start end)
 288   "Like `aa2u' on the region-rectangle.
 289 When called from a program the rectangle's corners
 290 are START (top left) and END (bottom right)."
 291   (interactive "r")
 292   (let* ((was (delete-extract-rectangle start end))
 293          (now (with-temp-buffer
 294                 (insert-rectangle was)
 295                 (aa2u (point) (mark))
 296                 (extract-rectangle (point-min) (point-max)))))
 297     (goto-char (min start end))
 298     (insert-rectangle now)))
 299
 300 ;;;###autoload
 301 (defun aa2u-mark-as-text (start end &optional unmark)
 302   "Set property `aa2u-text' of the text from START to END.
 303 This prevents `aa2u' from misinterpreting \"|\", \"-\" and \"+\"
 304 in that region as lines and intersections to be replaced.
 305 Prefix arg means to remove property `aa2u-text', instead."
 306   (interactive "r\nP")
 307   (funcall (if unmark
 308                'remove-text-properties
 309              'add-text-properties)
 310            start end
 311            '(aa2u-text t)))
 312
 313 ;;;###autoload
 314 (defun aa2u-mark-rectangle-as-text (start end &optional unmark)
 315   "Like `aa2u-mark-as-text' on the region-rectangle.
 316 When called from a program the rectangle's corners
 317 are START (top left) and END (bottom right)."
 318   (interactive "r\nP")
 319   (apply-on-rectangle
 320    (lambda (scol ecol unmark)
 321      (let ((p (point)))
 322        (aa2u-mark-as-text (+ p scol) (+ p ecol) unmark)))
 323    start end
 324    unmark))
 325
 326 ;;;---------------------------------------------------------------------------
 327 ;;; that's it
 328
 329 (provide 'ascii-art-to-unicode)
 330
 331 ;;; ascii-art-to-unicode.el ends here