;;; transliterate.el --- Transliterate text          -*- lexical-binding: t; -*-

;; Copyright (C) 2023  Philip Kaludercic

;; Author: Philip Kaludercic <philip.kaludercic@fau.de>
;; Maintainer: Philip Kaludercic <philip.kaludercic@fau.de>
;; Version: $Id: transliterate.el,v 1.1 2023/12/02 13:10:32 oj14ozun Exp $
;; Package-Requires: ((emacs "26.1"))
;; Package-Version: 1
;; Keywords: wp

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This file defines a set of commands for transliterating between
;; ASCII and Unicode characters, on different text entities.  You can
;; prompt Emacs for all commands using:
;;
;;   M-x apropos-command ^transliterate-

;;; Code:

(defvar transliterate-classes
  (eval-when-compile
    (defun transliterate-table (&rest prefixes)
      "Generate two character tables for mapping PREFIXES.
Each argument PREFIXES is the beginning of a unicode character
name, that without loss of generality, for any letter \"a\" be
appended with \"CAPITAL A\", \"SMALL A\", \"CAPITAL LETTER A\"
and \"SMALL LETTER A\", gathering all possible mappings in one
table, and the reverse associations in the second table."
      (let ((table (make-char-table 'translation-table))
	    (rtable (make-char-table 'translation-table))
	    (map (mapcan
		  (lambda (prefix)
		    (mapcan
		     (lambda (name)
		       (let ((fmt (concat prefix (car name)))
			     (rules '()))
			 (dolist (c (number-sequence ?A ?Z))
			   (let ((char (char-from-name (format fmt c))))
			     (when char
			       (push (cons (if (cdr name) (downcase c) c) char)
				     rules))))
			 rules))
		     '((" CAPITAL %c" . nil)
		       (" SMALL %c" . t)
		       (" CAPITAL LETTER %c" . nil)
		       (" SMALL LETTER %c" . t))))
		  prefixes)))
	(dolist (ent map)
	  (aset table (car ent) (cdr ent))
	  (aset rtable (cdr ent) (car ent)))
	(cons table rtable)))
    
    `((double-struck . ,(transliterate-table "DOUBLE-STRUCK" "MATHEMATICAL DOUBLE-STRUCK"))
      (mathematical-bold . ,(transliterate-table "MATHEMATICAL BOLD"))
      (mathematical-italic . ,(transliterate-table "MATHEMATICAL ITALIC"))
      (mathematical-bold-italic . ,(transliterate-table "MATHEMATICAL BOLD ITALIC"))
      (mathematical-sans-serif . ,(transliterate-table "MATHEMATICAL SANS-SERIF"))
      (mathematical-sans-serif-bold . ,(transliterate-table "MATHEMATICAL SANS-SERIF BOLD"))
      (mathematical-sans-serif-italic . ,(transliterate-table "MATHEMATICAL SANS-SERIF ITALIC"))
      (mathematical-sans-serif-bold-italic . ,(transliterate-table "MATHEMATICAL SANS-SERIF BOLD ITALIC"))
      (script . ,(transliterate-table "MATHEMATICAL SCRIPT" "SCRIPT"))
      (mathematical-fraktur . ,(transliterate-table "MATHEMATICAL FRAKTUR"))
      (subscript . ,(transliterate-table "LATIN SUBSCRIPT"))
      (modifier-letter . ,(transliterate-table "MODIFIER LETTER"))
      (small . ,(transliterate-table "LATIN LETTER SMALL"))
      (parenthesized . ,(transliterate-table "PARENTHESIZED LATIN"))
      (fullwidth . ,(transliterate-table "FULLWIDTH LATIN"))
      (circled . ,(transliterate-table "CIRCLED LATIN"))
      (negative-circled . ,(transliterate-table "NEGATIVE CIRCLED LATIN"))
      (squared . ,(transliterate-table "SQUARED LATIN"))
      (negative-squared . ,(transliterate-table "NEGATIVE SQUARED LATIN")))))

(defun transliterate-make-cmd (class thing)
  "Return a command that will transliterate a THING using CLASS.
CLASS is a symbol defined as a key in the alist
`transliterate-classes', while THING is a symbol as understood by
`bounds-of-thing-at-point'."
  (let* ((class (alist-get class transliterate-classes nil nil #'string=))
	 (table (car class))
	 (rtable (cdr class)))
    (unless (char-table-p table) (error "Not a character table: %S" table))
    (unless (char-table-p rtable) (error "Not a character table: %S" rtable))
    (lambda (reverse)
      (interactive
       (list current-prefix-arg))
      (let ((bounds (bounds-of-thing-at-point thing)))
	(unless bounds
	  (user-error "No %s to transliterate" thing))
	(translate-region (car bounds) (cdr bounds) (if reverse rtable table))))))

(dolist (name (mapcar #'car transliterate-classes))
  (dolist (thing '(region word paragraph sentence buffer))
    (let ((fn (intern (format "transliterate-%s-%s" name thing))))
      (defalias fn (transliterate-make-cmd name thing))
      (put fn 'function-documentation
	   (format "Transliterate %s at point to or from %s." thing name)))))

(provide 'transliterate)
;;; transliterate.el ends here