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.4
   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 ;; TODO:
  60 ;; - Add phase 0, to grok and lock label (as opposed to line) text.
  61 ;; - Add interactive mode, to choose per-line light vs heavy.
  62 ;; - Improve neighbor-determining heuristic.
  63 ;; - Choose plus-replacement by composing "VERTICAL", "LEFT", etc.
  64
  65 ;;; News:
  66
  67 ;; - 1.4 | 2014-01-14
  68 ;;   - move to ELPA (from <http://www.gnuvola.org/software/j/aa2u/>)
  69 ;;   - change copyright to FSF
  70 ;;   - require 'cl-lib instead of 'cl
  71 ;;   - use ‘cl-flet’ and ‘cl-labels’
  72 ;;   - comment munging
  73 ;;     - add ‘lexical-binding: t’
  74 ;;     - remove huge list at EOF
  75 ;;     - add Author and News headers
  76 ;;
  77 ;; - 1.3 | 2013-09-21
  78 ;;   - bug fixed: ‘?+’ neighbor valuation polarity flipped
  79 ;;   - new support for BOX DRAWINGS LIGHT {UP,DOWN,LEFT,RIGHT} (singleton)
  80 ;;
  81 ;; - 1.2 | 2012-11-05
  82 ;;   - refer to Unicode characters by name, not number
  83 ;;
  84 ;; - 1.1 | 2012-04-17
  85 ;;   - TAB agnostic
  86 ;;   - ‘aa2u’ operates on active region if ‘use-region-p’
  87 ;;   - example use case also demonstrates transformation
  88 ;;
  89 ;; - 1.0 | 2012-04-07
  90 ;;   - initial release
  91
  92 ;;; Code:
  93
  94 (require 'cl-lib)
  95 (require 'pcase)
  96
  97 ;;;---------------------------------------------------------------------------
  98 ;;; support
  99
 100 (defun aa2u-ucs-bd-uniform-name (weight &rest components)
 101   "Return a string naming UCS char w/ WEIGHT and COMPONENTS.
 102 The string begins with \"BOX DRAWINGS\"; followed by WEIGHT,
 103 a symbol from the set:
 104
 105   HEAVY
 106   LIGHT
 107
 108 followed by COMPONENTS, a list of one or two symbols from the set:
 109
 110   VERTICAL
 111   HORIZONTAL
 112   DOWN
 113   UP
 114   RIGHT
 115   LEFT
 116
 117 If of length two, the first element in COMPONENTS should be
 118 the \"Y-axis\" (VERTICAL, DOWN, UP).  In that case, the returned
 119 string includes \"AND\" between the elements of COMPONENTS.
 120
 121 Lastly, all words are separated by space (U+20)."
 122   (format "BOX DRAWINGS %s %s"
 123           weight
 124           (mapconcat 'symbol-name components
 125                      " AND ")))
 126
 127 (defun aa2u-1c (stringifier &rest components)
 128   "Apply STRINGIFIER to COMPONENTS; return the UCS char w/ this name.
 129 The char is a string (of length one), with two properties:
 130
 131   aa2u-stringifier
 132   aa2u-components
 133
 134 Their values are STRINGIFIER and COMPONENTS, respectively."
 135   (let ((s (string (cdr (assoc-string (apply stringifier components)
 136                                       (ucs-names))))))
 137     (propertize s
 138                 'aa2u-stringifier stringifier
 139                 'aa2u-components components)))
 140
 141 (defun aa2u-phase-1 ()
 142   (goto-char (point-min))
 143   (let ((vert (aa2u-1c 'aa2u-ucs-bd-uniform-name 'LIGHT 'VERTICAL)))
 144     (while (search-forward "|" nil t)
 145       (replace-match vert t t)))
 146   (goto-char (point-min))
 147   (let ((horz (aa2u-1c 'aa2u-ucs-bd-uniform-name 'LIGHT 'HORIZONTAL)))
 148     (while (search-forward "-" nil t)
 149       (replace-match horz t t))))
 150
 151 (defun aa2u-replacement (pos)
 152   (let ((cc (- pos (line-beginning-position))))
 153     (cl-labels
 154         ((ok (name pos)
 155              (when (or
 156                     ;; Infer LIGHTness between "snug" ‘?+’es.
 157                     ;;              |
 158                     ;;  +-----------++--+   +
 159                     ;;  | somewhere ++--+---+-+----+
 160                     ;;  +-+---------+ nowhere |+--+
 161                     ;;    +         +---------++
 162                     ;;              |      +---|
 163                     (eq ?+ (char-after pos))
 164                     ;; Require properly directional neighborliness.
 165                     (memq (case name
 166                             ((n s) 'VERTICAL)
 167                             ((w e) 'HORIZONTAL))
 168                           (get-text-property pos 'aa2u-components)))
 169                name))
 170          (v (name dir) (let ((bol (line-beginning-position dir))
 171                              (eol (line-end-position dir)))
 172                          (when (< cc (- eol bol))
 173                            (ok name (+ bol cc)))))
 174          (h (name dir) (let ((bol (line-beginning-position))
 175                              (eol (line-end-position))
 176                              (pos (+ pos dir)))
 177                          (unless (or (> bol pos)
 178                                      (<= eol pos))
 179                            (ok name pos))))
 180          (light (&rest components) (apply 'aa2u-1c
 181                                           'aa2u-ucs-bd-uniform-name
 182                                           'LIGHT components)))
 183       (let* ((n (v 'n 0))
 184              (s (v 's 2))
 185              (w (h 'w -1))
 186              (e (h 'e  1)))
 187         (pcase (delq nil (list n s w e))
 188           (`(n s w e) (light 'VERTICAL 'HORIZONTAL))
 189           (`(s e)     (light 'DOWN 'RIGHT))
 190           (`(s w)     (light 'DOWN 'LEFT))
 191           (`(n e)     (light 'UP 'RIGHT))
 192           (`(n w)     (light 'UP 'LEFT))
 193           (`(n s e)   (light 'VERTICAL 'RIGHT))
 194           (`(n s w)   (light 'VERTICAL 'LEFT))
 195           (`(n w e)   (light 'UP 'HORIZONTAL))
 196           (`(s w e)   (light 'DOWN 'HORIZONTAL))
 197           (`(n)       (light 'UP))
 198           (`(s)       (light 'DOWN))
 199           (`(w)       (light 'LEFT))
 200           (`(e)       (light 'RIGHT))
 201           (_          nil))))))
 202
 203 (defun aa2u-phase-2 ()
 204   (goto-char (point-min))
 205   (let (changes)
 206     ;; (phase 2.1 -- what WOULD change)
 207     ;; This is for the benefit of ‘aa2u-replacement ok’, which
 208     ;; otherwise (monolithic phase 2) would need to convert the
 209     ;; "properly directional neighborliness" impl from a simple
 210     ;; ‘memq’ to an ‘intersction’.
 211     (while (search-forward "+" nil t)
 212       (let ((p (point)))
 213         (push (cons p (or (aa2u-replacement (1- p))
 214                           "?"))
 215               changes)))
 216     ;; (phase 2.2 -- apply changes)
 217     (dolist (ch changes)
 218       (goto-char (car ch))
 219       (delete-char -1)
 220       (insert (cdr ch)))))
 221
 222 (defun aa2u-phase-3 ()
 223   (remove-text-properties (point-min) (point-max)
 224                           (list 'aa2u-stringifier nil
 225                                 'aa2u-components nil)))
 226
 227 ;;;---------------------------------------------------------------------------
 228 ;;; command
 229
 230 ;;;###autoload
 231 (defun aa2u ()
 232   "Convert simple ASCII art line drawings to Unicode.
 233 Specifically, perform the following replacements:
 234
 235   - (hyphen)          BOX DRAWINGS LIGHT HORIZONTAL
 236   | (vertical bar)    BOX DRAWINGS LIGHT VERTICAL
 237   + (plus)            (one of)
 238                       BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
 239                       BOX DRAWINGS LIGHT DOWN AND RIGHT
 240                       BOX DRAWINGS LIGHT DOWN AND LEFT
 241                       BOX DRAWINGS LIGHT UP AND RIGHT
 242                       BOX DRAWINGS LIGHT UP AND LEFT
 243                       BOX DRAWINGS LIGHT VERTICAL AND RIGHT
 244                       BOX DRAWINGS LIGHT VERTICAL AND LEFT
 245                       BOX DRAWINGS LIGHT UP AND HORIZONTAL
 246                       BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
 247                       BOX DRAWINGS LIGHT UP
 248                       BOX DRAWINGS LIGHT DOWN
 249                       BOX DRAWINGS LIGHT LEFT
 250                       BOX DRAWINGS LIGHT RIGHT
 251                       QUESTION MARK
 252
 253 More precisely, hyphen and vertical bar are substituted unconditionally,
 254 first, and plus is substituted with a character depending on its north,
 255 south, east and west neighbors.
 256
 257 This command operates on either the active region, as per
 258 `use-region-p', or the accessible portion otherwise."
 259   (interactive)
 260   (save-excursion
 261     (cl-flet
 262         ((do-it! () (aa2u-phase-1) (aa2u-phase-2) (aa2u-phase-3)))
 263       (if (use-region-p)
 264           (let ((beg (region-beginning))
 265                 (end (region-end)))
 266             (save-restriction
 267               (widen)
 268               (narrow-to-region beg end)
 269               (do-it!)))
 270         (do-it!)))))
 271
 272 ;;;---------------------------------------------------------------------------
 273 ;;; that's it
 274
 275 (provide 'ascii-art-to-unicode)
 276
 277 ;;; ascii-art-to-unicode.el ends here