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