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 ;; 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 ;;; Code:
  98
  99 (require 'cl-lib)
 100 (require 'pcase)
 101
 102 (autoload 'apply-on-rectangle "rect")
 103
 104 (defvar aa2u-uniform-weight 'LIGHT
 105   "A symbol, either `LIGHT' or `HEAVY'.
 106 This specifies the weight of all the lines.")
 107
 108 ;;;---------------------------------------------------------------------------
 109 ;;; support
 110
 111 (defsubst aa2u--text-p (pos)
 112   (get-text-property pos 'aa2u-text))
 113
 114 (defun aa2u-ucs-bd-uniform-name (&rest components)
 115   "Return a string naming UCS char w/ WEIGHT and COMPONENTS.
 116 The string begins with \"BOX DRAWINGS\"; followed by the weight
 117 as per variable `aa2u-uniform-weight', followed by COMPONENTS,
 118 a list of one or two symbols from the set:
 119
 120   VERTICAL
 121   HORIZONTAL
 122   DOWN
 123   UP
 124   RIGHT
 125   LEFT
 126
 127 If of length two, the first element in COMPONENTS should be
 128 the \"Y-axis\" (VERTICAL, DOWN, UP).  In that case, the returned
 129 string includes \"AND\" between the elements of COMPONENTS.
 130
 131 Lastly, all words are separated by space (U+20)."
 132   (format "BOX DRAWINGS %s %s"
 133           aa2u-uniform-weight
 134           (mapconcat 'symbol-name components
 135                      " AND ")))
 136
 137 (defun aa2u-1c (stringifier &rest components)
 138   "Apply STRINGIFIER to COMPONENTS; return the UCS char w/ this name.
 139 The char is a string (of length one), with two properties:
 140
 141   aa2u-stringifier
 142   aa2u-components
 143
 144 Their values are STRINGIFIER and COMPONENTS, respectively."
 145   (let ((s (string (cdr (assoc-string (apply stringifier components)
 146                                       (ucs-names))))))
 147     (propertize s
 148                 'aa2u-stringifier stringifier
 149                 'aa2u-components components)))
 150
 151 (defun aa2u-phase-1 ()
 152   (cl-flet
 153       ((gsr (was name)
 154             (goto-char (point-min))
 155             (let ((now (aa2u-1c 'aa2u-ucs-bd-uniform-name name)))
 156               (while (search-forward was nil t)
 157                 (unless (aa2u--text-p (match-beginning 0))
 158                   (replace-match now t t))))))
 159     (gsr "|" 'VERTICAL)
 160     (gsr "-" 'HORIZONTAL)))
 161
 162 (defun aa2u-replacement (pos)
 163   (let ((cc (- pos (line-beginning-position))))
 164     (cl-flet*
 165         ((ok (name pos)
 166              (when (or
 167                     ;; Infer LIGHTness between "snug" ‘?+’es.
 168                     ;;              |
 169                     ;;  +-----------++--+   +
 170                     ;;  | somewhere ++--+---+-+----+
 171                     ;;  +-+---------+ nowhere |+--+
 172                     ;;    +         +---------++
 173                     ;;              |      +---|
 174                     (eq ?+ (char-after pos))
 175                     ;; Require properly directional neighborliness.
 176                     (memq (cl-case name
 177                             ((UP DOWN)    'VERTICAL)
 178                             ((LEFT RIGHT) 'HORIZONTAL))
 179                           (get-text-property pos 'aa2u-components)))
 180                name))
 181          (v (name dir) (let ((bol (line-beginning-position dir))
 182                              (eol (line-end-position dir)))
 183                          (when (< cc (- eol bol))
 184                            (ok name (+ bol cc)))))
 185          (h (name dir) (let ((bol (line-beginning-position))
 186                              (eol (line-end-position))
 187                              (pos (+ pos dir)))
 188                          (unless (or (> bol pos)
 189                                      (<= eol pos))
 190                            (ok name pos))))
 191          (two-p (ls) (= 2 (length ls)))
 192          (just (&rest args) (delq nil args)))
 193       (apply 'aa2u-1c
 194              'aa2u-ucs-bd-uniform-name
 195              (just (pcase (just (v 'UP   0)
 196                                 (v 'DOWN 2))
 197                      ((pred two-p) 'VERTICAL)
 198                      (`(,vc)        vc)
 199                      (_             nil))
 200                    (pcase (just (h 'LEFT  -1)
 201                                 (h 'RIGHT  1))
 202                      ((pred two-p) 'HORIZONTAL)
 203                      (`(,hc)        hc)
 204                      (_             nil)))))))
 205
 206 (defun aa2u-phase-2 ()
 207   (goto-char (point-min))
 208   (let (changes)
 209     ;; (phase 2.1 -- what WOULD change)
 210     ;; This is for the benefit of ‘aa2u-replacement ok’, which
 211     ;; otherwise (monolithic phase 2) would need to convert the
 212     ;; "properly directional neighborliness" impl from a simple
 213     ;; ‘memq’ to an ‘intersction’.
 214     (while (search-forward "+" nil t)
 215       (let ((p (point)))
 216         (unless (aa2u--text-p (1- p))
 217           (push (cons p (or (aa2u-replacement (1- p))
 218                             "?"))
 219                 changes))))
 220     ;; (phase 2.2 -- apply changes)
 221     (dolist (ch changes)
 222       (goto-char (car ch))
 223       (delete-char -1)
 224       (insert (cdr ch)))))
 225
 226 (defun aa2u-phase-3 ()
 227   (remove-text-properties (point-min) (point-max)
 228                           (list 'aa2u-stringifier nil
 229                                 'aa2u-components nil)))
 230
 231 ;;;---------------------------------------------------------------------------
 232 ;;; commands
 233
 234 ;;;###autoload
 235 (defun aa2u (beg end &optional interactive)
 236   "Convert simple ASCII art line drawings to Unicode.
 237 Specifically, perform the following replacements:
 238
 239   - (hyphen)          BOX DRAWINGS LIGHT HORIZONTAL
 240   | (vertical bar)    BOX DRAWINGS LIGHT VERTICAL
 241   + (plus)            (one of)
 242                       BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
 243                       BOX DRAWINGS LIGHT DOWN AND RIGHT
 244                       BOX DRAWINGS LIGHT DOWN AND LEFT
 245                       BOX DRAWINGS LIGHT UP AND RIGHT
 246                       BOX DRAWINGS LIGHT UP AND LEFT
 247                       BOX DRAWINGS LIGHT VERTICAL AND RIGHT
 248                       BOX DRAWINGS LIGHT VERTICAL AND LEFT
 249                       BOX DRAWINGS LIGHT UP AND HORIZONTAL
 250                       BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
 251                       BOX DRAWINGS LIGHT UP
 252                       BOX DRAWINGS LIGHT DOWN
 253                       BOX DRAWINGS LIGHT LEFT
 254                       BOX DRAWINGS LIGHT RIGHT
 255                       QUESTION MARK
 256
 257 More precisely, hyphen and vertical bar are substituted unconditionally,
 258 first, and plus is substituted with a character depending on its north,
 259 south, east and west neighbors.
 260
 261 NB: Actually, `aa2u' can also use \"HEAVY\" instead of \"LIGHT\",
 262 depending on the value of variable `aa2u-uniform-weight'.
 263
 264 This command operates on either the active region,
 265 or the accessible portion otherwise."
 266   (interactive "r\np")
 267   ;; This weirdness, along w/ the undocumented "p" in the ‘interactive’
 268   ;; form, is to allow ‘M-x aa2u’ (interactive invocation) w/ no region
 269   ;; selected to default to the accessible portion (as documented), which
 270   ;; was the norm in ascii-art-to-unicode.el prior to 1.5.  A bugfix,
 271   ;; essentially.  This is ugly, unfortunately -- is there a better way?!
 272   (when (and interactive (not (region-active-p)))
 273     (setq beg (point-min)
 274           end (point-max)))
 275   (save-excursion
 276     (save-restriction
 277       (widen)
 278       (narrow-to-region beg end)
 279       (aa2u-phase-1)
 280       (aa2u-phase-2)
 281       (aa2u-phase-3))))
 282
 283 ;;;###autoload
 284 (defun aa2u-rectangle (start end)
 285   "Like `aa2u' on the region-rectangle.
 286 When called from a program the rectangle's corners
 287 are START (top left) and END (bottom right)."
 288   (interactive "r")
 289   (let* ((was (delete-extract-rectangle start end))
 290          (now (with-temp-buffer
 291                 (insert-rectangle was)
 292                 (aa2u (point) (mark))
 293                 (extract-rectangle (point-min) (point-max)))))
 294     (goto-char (min start end))
 295     (insert-rectangle now)))
 296
 297 ;;;###autoload
 298 (defun aa2u-mark-as-text (start end &optional unmark)
 299   "Set property `aa2u-text' of the text from START to END.
 300 This prevents `aa2u' from misinterpreting \"|\", \"-\" and \"+\"
 301 in that region as lines and intersections to be replaced.
 302 Prefix arg means to remove property `aa2u-text', instead."
 303   (interactive "r\nP")
 304   (funcall (if unmark
 305                'remove-text-properties
 306              'add-text-properties)
 307            start end
 308            '(aa2u-text t)))
 309
 310 ;;;###autoload
 311 (defun aa2u-mark-rectangle-as-text (start end &optional unmark)
 312   "Like `aa2u-mark-as-text' on the region-rectangle.
 313 When called from a program the rectangle's corners
 314 are START (top left) and END (bottom right)."
 315   (interactive "r\nP")
 316   (apply-on-rectangle
 317    (lambda (scol ecol unmark)
 318      (let ((p (point)))
 319        (aa2u-mark-as-text (+ p scol) (+ p ecol) unmark)))
 320    start end
 321    unmark))
 322
 323 ;;;---------------------------------------------------------------------------
 324 ;;; that's it
 325
 326 (provide 'ascii-art-to-unicode)
 327
 328 ;;; ascii-art-to-unicode.el ends here