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