A small-caps input method, and functions to translate from and to them

Download this file here.


;; -*- coding: utf-8 -*-

(defun char-table-key-list (char-table)
  (check-argument-type #'char-table-p char-table)
  (let (res)
    (map-char-table #'(lambda (key value) (push key res) nil) char-table)
    res))

(defun char-table-value-list (char-table)
  (check-argument-type #'char-table-p char-table)
  (let (res)
    (map-char-table (lambda (key value)
                      (push value res)
                      nil) char-table)
    res))

(defconst latin-to-small-caps-latin-map
  #s(char-table type char data
                (?a ?ᴀ ?b ?ᴃ ?c ?ᴄ ?d ?ᴅ ?e ?ᴇ ?f ?ғ ?g ?ɢ ?h ?ʜ ?i ?ɪ ?j ?ᴊ
                 ?k ?ᴋ ?l ?ʟ ?m ?ᴍ ?n ?ɴ ?o ?ᴏ ?p ?ᴘ ?q ?ǫ ?r ?ʀ ?s ?s ?t ?ᴛ
                 ?u ?ᴜ ?v ?ᴠ ?w ?ᴡ ?x ?x ?y ?ʏ ?z ?ᴢ ?A ?ᴀ ?B ?ᴃ ?C ?ᴄ ?D ?ᴅ
                 ?E ?ᴇ ?F ?ғ ?G ?ɢ ?H ?ʜ ?I ?ɪ ?J ?ᴊ ?K ?ᴋ ?L ?ʟ ?M ?ᴍ ?N ?ɴ
                 ?O ?ᴏ ?P ?ᴘ ?Q ?ǫ ?R ?ʀ ?S ?s ?T ?ᴛ ?U ?ᴜ ?V ?ᴠ ?W ?ᴡ ?X ?x
                 ?Y ?ʏ ?Z ?ᴢ ?\ ?·)))

(defun small-caps-and-middot-region (begin end)
  "Make the lower case Roman chars between BEGIN and END small caps."
  (interactive "r")
  (save-excursion
    (save-restriction
      (narrow-to-region begin end)
      (goto-char begin)
      (while (not (zerop (setq begin (skip-chars-forward "^a-z ")
                               end (skip-chars-forward "a-z "))))
        (translate-region (point) (- (point) end) 
                          latin-to-small-caps-latin-map)))))

(quail-define-package
 "small-capitals" "UTF-8" "SC" t
 "Roman alphabet, in small caps; upper case remains ASCII.

Unicode provides 20 of the 26 small capital characters necessary for
encoding the Roman alphabet in small caps.  (Unicode doesn't view small caps
as its responsibility, whence the absence of the others.)  This input method
uses them together with a couple of Cyrillic characters (в and ғ for B and
F, respectively) and a Central European European character (ǫ for Q).  No
translation is provided for s, which normally doesn't differ visually in
outline when its case is changed.

The further small caps characters OE, AE and L WITH STROKE are also
supported.  ")

(quail-define-rules
 ("a" "\u1D00")  ;; U+1D00 LATIN LETTER SMALL CAPITAL A
 ("b" "\u0432")  ;; U+0432 CYRILLIC SMALL LETTER VE
 ("c" "\u1D04")  ;; U+1D04 LATIN LETTER SMALL CAPITAL C
 ("d" "\u1D05")  ;; U+1D05 LATIN LETTER SMALL CAPITAL D
 ("e" "\u1D07")  ;; U+1D07 LATIN LETTER SMALL CAPITAL E
 ("f" "\u0493")  ;; U+0493 CYRILLIC SMALL LETTER GHE WITH STROKE
 ("g" "\u0262")  ;; U+0262 LATIN LETTER SMALL CAPITAL G
 ("h" "\u029C")  ;; U+029C LATIN LETTER SMALL CAPITAL H
 ("i" "\u026A")  ;; U+026A LATIN LETTER SMALL CAPITAL I
 ("j" "\u1D0A")  ;; U+1D0A LATIN LETTER SMALL CAPITAL J
 ("k" "\u1D0B")  ;; U+1D0B LATIN LETTER SMALL CAPITAL K
 ("l" "\u029F")  ;; U+029F LATIN LETTER SMALL CAPITAL L
 ("m" "\u1D0D")  ;; U+1D0D LATIN LETTER SMALL CAPITAL M
 ("n" "\u0274")  ;; U+0274 LATIN LETTER SMALL CAPITAL N
 ("o" "\u1D0F")  ;; U+1D0F LATIN LETTER SMALL CAPITAL O
 ("p" "\u1D18")  ;; U+1D18 LATIN LETTER SMALL CAPITAL P
 ("q" "\u01EB")  ;; U+01EB LATIN SMALL LETTER O WITH OGONEK
 ("r" "\u0280")  ;; U+0280 LATIN LETTER SMALL CAPITAL R
 ;; No s. 
 ("t" "\u1D1B")  ;; U+1D1B LATIN LETTER SMALL CAPITAL T
 ("u" "\u1D1C")  ;; U+1D1C LATIN LETTER SMALL CAPITAL U
 ("v" "\u1D20")  ;; U+1D20 LATIN LETTER SMALL CAPITAL V
 ("w" "\u1D21")  ;; U+1D21 LATIN LETTER SMALL CAPITAL W
 ("z" "\u1D22")  ;; U+1D22 LATIN LETTER SMALL CAPITAL Z

 ("oe" "\u0276") ;; U+0276 LATIN LETTER SMALL CAPITAL OE
 ("ae" "\u1D01") ;; U+1D01 LATIN LETTER SMALL CAPITAL AE
 ("l/" "\u1D0C") ;; U+1D0C LATIN LETTER SMALL CAPITAL L WITH STROKE

 ("oee" ["\u1D0F\u1D07"]) ;; Provide small caps OE if the user types oee.
 ("aee" ["\u1D00\u1D07"]) ;; aee -> AE
 ("l//" ["\u029F/"]))     ;; l// -> L/

;; thanks, ıt's ǝvǝn bǝttǝr than ı thouƃht˙ sǝcurǝ passwords for thǝ wın˙

;; reverse;tr/abcdefghijklmnopqrvwxyz/ɐqɔpəɟɓɥɪʆʞʅɯuodbɹsʇnʌxʎz/;

(defconst latin-to-inverted-map
  #s(char-table type char data
                (?a ?ɐ ?b ?q ?c ?ɔ ?d ?p ?e ?ə ?f ?ɟ ?g ?ɓ ?h ?ɥ ?i ?ɪ ?j ?ʆ
                 ?k ?ʞ ?l ?ʅ ?m ?ɯ ?n ?u ?o ?o ?p ?d ?q ?b ?r ?ɹ ?s ?s ?t ?ʇ
                 ?u ?n ?v ?ʌ ?w ?ʍ ?x ?x ?y ?ʎ ?z ?z ?! ?¡ ?, ?' ?\( ?\) ?\)
                 ?\( ?. ?· ?' ?, ?\? ?¿ ?! ?¡)))

(defconst inverted-to-latin-map
  (let ((res (make-char-table 'char)))
    (map-char-table #'(lambda (key value) (put-char-table value key res) nil)
                    latin-to-inverted-map)
    res))

(defun invert-and-reverse-region (begin end)
  "Make the lower case Roman chars between BEGIN and END small caps."
  (interactive "r")
  (save-excursion
    (save-restriction
      (let* ((work-begin begin) (work-end end) str
             (inclusive-range (apply #'string 
                                   (char-table-key-list latin-to-inverted-map)))
             (exclusive-range (concat "^" inclusive-range)))
        (narrow-to-region begin end)
        (goto-char begin)
        (while (not (zerop (setq work-begin
                                 (skip-chars-forward exclusive-range)
                                 work-end
                                 (skip-chars-forward inclusive-range))))
          (translate-region (point) (- (point) work-end) 
                            latin-to-inverted-map))
        (setq str (buffer-substring begin end))
        (goto-char begin)
        (delete-region begin end)
        (apply #'insert (reverse (append str nil)))))))

(defun de-invert-and-reverse-region (begin end)
  "Make the lower case Roman chars between BEGIN and END small caps."
  (interactive "r")
  (save-excursion
    (save-restriction
      (let* ((work-begin begin) (work-end end) str
             (inclusive-range (apply #'string 
                                   (char-table-key-list inverted-to-latin-map)))
             (exclusive-range (concat "^" inclusive-range)))
        (narrow-to-region begin end)
        (goto-char begin)
        (while (not (zerop (setq work-begin
                                 (skip-chars-forward exclusive-range)
                                 work-end
                                 (skip-chars-forward inclusive-range))))
          (translate-region (point) (- (point) work-end) 
                            inverted-to-latin-map))
        (setq str (buffer-substring begin end))
        (goto-char begin)
        (delete-region begin end)
        (apply #'insert (reverse (append str nil)))))))