cgit.sxemacs.org Git - packages/blob - mule-packages/latin-unity/latin-unity-utils.el

   1 ;;; latin-unity-utils.el --- Utility functions for preparing latin-unity data
   2
   3 ;; Copyright (C) 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: Stephen J. Turnbull
   6 ;; Keywords: mule, charsets
   7 ;; Created: 2002 January 26
   8 ;; Last-modified: 2002 March 23
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Mule bogusly considers the various ISO-8859 extended character sets
  30 ;; as disjoint, when ISO 8859 itself clearly considers them to be subsets
  31 ;; of a larger character set.
  32
  33 ;; This library provides functions which for creating databases of
  34 ;; equivalence classes of characters.
  35
  36 ;; It is NOT REQUIRED for the use of latin-unity.el; only for creating
  37 ;; the data it uses (provided in latin-unity-tables.el).
  38
  39 ;; This is a developer-only library; _do not_ autoload anything in it.
  40
  41 ;;; Code:
  42
  43 (provide 'latin-unity-utils)
  44 (provide 'latin-unity-tables)   ; Not a lie.
  45
  46 ;;; Requires
  47 (require 'cl)
  48 (load "cl-macs" nil t)                  ; howcum no #'provide?
  49 ;; Get the charsets, among other things
  50 (require 'latin-unity-vars)
  51
  52 (defvar latin-unity-utils-found-unicode-support t)
  53
  54 (condition-case nil
  55     (if (fboundp 'char-to-unicode)
  56         (defalias 'latin-unity-char-to-unicode 'char-to-unicode)
  57       ;; The following libraries are from Mule-UCS.  This dependency
  58       ;; can be eliminated by providing latin-unity-char-to-unicode.
  59       (require 'mule-ucs-unicode "unicode")
  60       (require 'un-define)
  61       (defalias 'latin-unity-char-to-unicode 'char-to-ucs))
  62   (file-error (setq latin-unity-utils-found-unicode-support nil)))
  63
  64 ;; Table of character set support for each Unicode code point
  65 ;; Hard-coded tables are from etc/unicode/unicode.org in XEmacs 21.5.
  66
  67 ;; Populate the equivalence table
  68 (when latin-unity-utils-found-unicode-support
  69 (let* ((u+index (1+ (length latin-unity-character-sets))) ; alias
  70        (zero (make-vector (1+ u+index) nil))              ; useful constant
  71        ;; temporary holding tank for equivs: list of Mule characters
  72        ;; equivalent to the Unicode code point
  73        (unitable (make-vector (1+ #x20AC) nil)))
  74
  75   ;;
  76   ;; ASCII is spatial, Mule treats C0, SPC, and DEL as ASCII, but
  77   ;; (= (charset-property 'ascii 'chars) 94) :-(
  78   (loop for i from #x00 to #x7F do
  79     (let* ((ch (make-char 'ascii i))    ; multibyte dirty
  80            (ucs (latin-unity-char-to-unicode ch)))
  81       (if (and ucs (/= ucs -1))
  82           (aset unitable ucs (cons ch (aref unitable ucs)))
  83         ;; Unfortunately it seems that Mule-UCS doesn't know Latin-9....
  84         ;; It also is smart enough to know that there are holes in Latin-3.
  85         (message "Your Unicode support doesn't know about %s"
  86                  (split-char ch)))))
  87
  88   ;; Other character sets
  89   ;; Control-1 is spatial, but handled below
  90   ;; NB: JIS Roman defaults to differing from ASCII
  91   (mapc (lambda (cs)
  92           (let (lo hi)
  93             ;; cond because Morioka added a lot of extra sizes
  94             ;; not relevant to our Latin character sets
  95             (message "Processing charset %s ..." cs)
  96             (cond ((= (charset-property cs 'chars) 94)
  97                    (setq lo #x21 hi #x7E))
  98                   ((= (charset-property cs 'chars) 96)
  99                    (setq lo #x20 hi #x7F))
 100                   (t (message "Odd size character set (%s)!" cs)
 101                      (setq lo #x20 hi #x7F)))
 102             (loop for i from lo to hi do
 103               (let* ((ch (make-char cs i)) ; multibyte dirty
 104                      (ucs (latin-unity-char-to-unicode ch)))
 105                 (if (and ucs (/= ucs -1))
 106                     (aset unitable ucs (cons ch (aref unitable ucs)))
 107                   (message "Your Unicode support doesn't know about %s"
 108                            (split-char ch)))))))
 109         (set-difference (copy-sequence latin-unity-character-sets)
 110                         '(ascii latin-iso8859-13 latin-iso8859-14
 111                           latin-iso8859-15 latin-iso8859-16)))
 112
 113   ;; Latin-7, -8, -9, and -10 are spatial, Mule-UCS doesn't handle them
 114   ;; correctly (maybe because they're not built in?)
 115   ;; Latin-7 (ISO 8859/13)
 116   (when (find-coding-system 'iso-8859-13)
 117     (message "Processing charset %s ..." 'latin-iso8859-13)
 118     (mapc (lambda (pair)
 119             (let ((ucs (cdr pair))
 120                   (ch (make-char 'latin-iso8859-13 (car pair))))
 121               (aset unitable ucs (cons ch (aref unitable ucs)))))
 122           '((#xA0 . #x00A0) (#xA1 . #x201D) (#xA2 . #x00A2) (#xA3 . #x00A3)
 123             (#xA4 . #x00A4) (#xA5 . #x201E) (#xA6 . #x00A6) (#xA7 . #x00A7)
 124             (#xA8 . #x00D8) (#xA9 . #x00A9) (#xAA . #x0156) (#xAB . #x00AB)
 125             (#xAC . #x00AC) (#xAD . #x00AD) (#xAE . #x00AE) (#xAF . #x00C6)
 126             (#xB0 . #x00B0) (#xB1 . #x00B1) (#xB2 . #x00B2) (#xB3 . #x00B3)
 127             (#xB4 . #x201C) (#xB5 . #x00B5) (#xB6 . #x00B6) (#xB7 . #x00B7)
 128             (#xB8 . #x00F8) (#xB9 . #x00B9) (#xBA . #x0157) (#xBB . #x00BB)
 129             (#xBC . #x00BC) (#xBD . #x00BD) (#xBE . #x00BE) (#xBF . #x00E6)
 130             (#xC0 . #x0104) (#xC1 . #x012E) (#xC2 . #x0100) (#xC3 . #x0106)
 131             (#xC4 . #x00C4) (#xC5 . #x00C5) (#xC6 . #x0118) (#xC7 . #x0112)
 132             (#xC8 . #x010C) (#xC9 . #x00C9) (#xCA . #x0179) (#xCB . #x0116)
 133             (#xCC . #x0122) (#xCD . #x0136) (#xCE . #x012A) (#xCF . #x013B)
 134             (#xD0 . #x0160) (#xD1 . #x0143) (#xD2 . #x0145) (#xD3 . #x00D3)
 135             (#xD4 . #x014C) (#xD5 . #x00D5) (#xD6 . #x00D6) (#xD7 . #x00D7)
 136             (#xD8 . #x0172) (#xD9 . #x0141) (#xDA . #x015A) (#xDB . #x016A)
 137             (#xDC . #x00DC) (#xDD . #x017B) (#xDE . #x017D) (#xDF . #x00DF)
 138             (#xE0 . #x0105) (#xE1 . #x012F) (#xE2 . #x0101) (#xE3 . #x0107)
 139             (#xE4 . #x00E4) (#xE5 . #x00E5) (#xE6 . #x0119) (#xE7 . #x0113)
 140             (#xE8 . #x010D) (#xE9 . #x00E9) (#xEA . #x017A) (#xEB . #x0117)
 141             (#xEC . #x0123) (#xED . #x0137) (#xEE . #x012B) (#xEF . #x013C)
 142             (#xF0 . #x0161) (#xF1 . #x0144) (#xF2 . #x0146) (#xF3 . #x00F3)
 143             (#xF4 . #x014D) (#xF5 . #x00F5) (#xF6 . #x00F6) (#xF7 . #x00F7)
 144             (#xF8 . #x0173) (#xF9 . #x0142) (#xFA . #x015B) (#xFB . #x016B)
 145             (#xFC . #x00FC) (#xFD . #x017C) (#xFE . #x017E) (#xFF . #x2019))))
 146   (when (find-coding-system 'iso-8859-14)
 147     (message "Processing charset %s ..." 'latin-iso8859-14)
 148     (mapc (lambda (pair)
 149             (let ((ucs (cdr pair))
 150                   (ch (make-char 'latin-iso8859-14 (car pair))))
 151               (aset unitable ucs (cons ch (aref unitable ucs)))))
 152           '((#xA0 . #x00A0) (#xA1 . #x1E02) (#xA2 . #x1E03) (#xA3 . #x00A3)
 153             (#xA4 . #x010A) (#xA5 . #x010B) (#xA6 . #x1E0A) (#xA7 . #x00A7)
 154             (#xA8 . #x1E80) (#xA9 . #x00A9) (#xAA . #x1E82) (#xAB . #x1E0B)
 155             (#xAC . #x1EF2) (#xAD . #x00AD) (#xAE . #x00AE) (#xAF . #x0178)
 156             (#xB0 . #x1E1E) (#xB1 . #x1E1F) (#xB2 . #x0120) (#xB3 . #x0121)
 157             (#xB4 . #x1E40) (#xB5 . #x1E41) (#xB6 . #x00B6) (#xB7 . #x1E56)
 158             (#xB8 . #x1E81) (#xB9 . #x1E57) (#xBA . #x1E83) (#xBB . #x1E60)
 159             (#xBC . #x1EF3) (#xBD . #x1E84) (#xBE . #x1E85) (#xBF . #x1E61)
 160             (#xC0 . #x00C0) (#xC1 . #x00C1) (#xC2 . #x00C2) (#xC3 . #x00C3)
 161             (#xC4 . #x00C4) (#xC5 . #x00C5) (#xC6 . #x00C6) (#xC7 . #x00C7)
 162             (#xC8 . #x00C8) (#xC9 . #x00C9) (#xCA . #x00CA) (#xCB . #x00CB)
 163             (#xCC . #x00CC) (#xCD . #x00CD) (#xCE . #x00CE) (#xCF . #x00CF)
 164             (#xD0 . #x0174) (#xD1 . #x00D1) (#xD2 . #x00D2) (#xD3 . #x00D3)
 165             (#xD4 . #x00D4) (#xD5 . #x00D5) (#xD6 . #x00D6) (#xD7 . #x1E6A)
 166             (#xD8 . #x00D8) (#xD9 . #x00D9) (#xDA . #x00DA) (#xDB . #x00DB)
 167             (#xDC . #x00DC) (#xDD . #x00DD) (#xDE . #x0176) (#xDF . #x00DF)
 168             (#xE0 . #x00E0) (#xE1 . #x00E1) (#xE2 . #x00E2) (#xE3 . #x00E3)
 169             (#xE4 . #x00E4) (#xE5 . #x00E5) (#xE6 . #x00E6) (#xE7 . #x00E7)
 170             (#xE8 . #x00E8) (#xE9 . #x00E9) (#xEA . #x00EA) (#xEB . #x00EB)
 171             (#xEC . #x00EC) (#xED . #x00ED) (#xEE . #x00EE) (#xEF . #x00EF)
 172             (#xF0 . #x0175) (#xF1 . #x00F1) (#xF2 . #x00F2) (#xF3 . #x00F3)
 173             (#xF4 . #x00F4) (#xF5 . #x00F5) (#xF6 . #x00F6) (#xF7 . #x1E6B)
 174             (#xF8 . #x00F8) (#xF9 . #x00F9) (#xFA . #x00FA) (#xFB . #x00FB)
 175             (#xFC . #x00FC) (#xFD . #x00FD) (#xFE . #x0177) (#xFF . #x00FF))))
 176   (when (find-coding-system 'iso-8859-15)
 177     (message "Processing charset %s ..." 'latin-iso8859-15)
 178     (loop for i from #x20 to #x7F do
 179       (let* ((ch (make-char 'latin-iso8859-15 i)) ; multibyte dirty
 180              (ucs (+ i #x80)))
 181         (aset unitable ucs (cons ch (aref unitable ucs)))))
 182     (mapc (lambda (ucs)
 183             (let ((ch (make-char 'latin-iso8859-15 ucs)))
 184               (aset unitable ucs (delq ch (aref unitable ucs)))))
 185           '(#xA4 #xA6 #xA8 #xB4 #xB8 #xBC #xBD #xBE))
 186     (mapc (lambda (pair)
 187             (let ((ucs (car pair))
 188                   (ch (make-char 'latin-iso8859-15 (cdr pair))))
 189               (aset unitable ucs (cons ch (aref unitable ucs)))))
 190           '((#x0152 . #xBC) (#x0153 . #xBD) (#x0160 . #xA6) (#x0161 . #xA8)
 191             (#x0178 . #xBE) (#x017D . #xB4) (#x017E . #xB8) (#x20AC . #xA4))))
 192   (when (find-coding-system 'iso-8859-16)
 193     (mapc (lambda (pair)
 194             (let ((ucs (cdr pair))
 195                   (ch (make-char 'latin-iso8859-16 (car pair))))
 196               (aset unitable ucs (cons ch (aref unitable ucs)))))
 197           '((#xA0 . #x00A0) (#xA1 . #x0104) (#xA2 . #x0105) (#xA3 . #x0141)
 198             (#xA4 . #x20AC) (#xA5 . #x201E) (#xA6 . #x0160) (#xA7 . #x00A7)
 199             (#xA8 . #x0161) (#xA9 . #x00A9) (#xAA . #x0218) (#xAB . #x00AB)
 200             (#xAC . #x0179) (#xAD . #x00AD) (#xAE . #x017A) (#xAF . #x017B)
 201             (#xB0 . #x00B0) (#xB1 . #x00B1) (#xB2 . #x010C) (#xB3 . #x0142)
 202             (#xB4 . #x017D) (#xB5 . #x201D) (#xB6 . #x00B6) (#xB7 . #x00B7)
 203             (#xB8 . #x017E) (#xB9 . #x010D) (#xBA . #x0219) (#xBB . #x00BB)
 204             (#xBC . #x0152) (#xBD . #x0153) (#xBE . #x0178) (#xBF . #x017C)
 205             (#xC0 . #x00C0) (#xC1 . #x00C1) (#xC2 . #x00C2) (#xC3 . #x0102)
 206             (#xC4 . #x00C4) (#xC5 . #x0106) (#xC6 . #x00C6) (#xC7 . #x00C7)
 207             (#xC8 . #x00C8) (#xC9 . #x00C9) (#xCA . #x00CA) (#xCB . #x00CB)
 208             (#xCC . #x00CC) (#xCD . #x00CD) (#xCE . #x00CE) (#xCF . #x00CF)
 209             (#xD0 . #x0110) (#xD1 . #x0143) (#xD2 . #x00D2) (#xD3 . #x00D3)
 210             (#xD4 . #x00D4) (#xD5 . #x0150) (#xD6 . #x00D6) (#xD7 . #x015A)
 211             (#xD8 . #x0170) (#xD9 . #x00D9) (#xDA . #x00DA) (#xDB . #x00DB)
 212             (#xDC . #x00DC) (#xDD . #x0118) (#xDE . #x021A) (#xDF . #x00DF)
 213             (#xE0 . #x00E0) (#xE1 . #x00E1) (#xE2 . #x00E2) (#xE3 . #x0103)
 214             (#xE4 . #x00E4) (#xE5 . #x0107) (#xE6 . #x00E6) (#xE7 . #x00E7)
 215             (#xE8 . #x00E8) (#xE9 . #x00E9) (#xEA . #x00EA) (#xEB . #x00EB)
 216             (#xEC . #x00EC) (#xED . #x00ED) (#xEE . #x00EE) (#xEF . #x00EF)
 217             (#xF0 . #x0111) (#xF1 . #x0144) (#xF2 . #x00F2) (#xF3 . #x00F3)
 218             (#xF4 . #x00F4) (#xF5 . #x0151) (#xF6 . #x00F6) (#xF7 . #x015B)
 219             (#xF8 . #x0171) (#xF9 . #x00F9) (#xFA . #x00FA) (#xFB . #x00FB)
 220             (#xFC . #x00FC) (#xFD . #x0119) (#xFE . #x021B) (#xFF . #x00FF))))
 221
 222   ;; Fill in the equivalences
 223
 224   ;; Default the whole equivalences table
 225   (aset zero 0 0)
 226   (put-char-table t zero latin-unity-equivalences)
 227
 228   ;; Control 1 code points are spatial
 229   ;; Warning on these is beyond the scope of this library.
 230   (put-char-table 'control-1
 231                   (vector latin-unity-all-flags
 232                           nil nil nil nil nil nil nil nil nil)
 233                   latin-unity-equivalences)
 234
 235   ;; Now map over the unitable to the equivalences char-table
 236   (mapc (lambda (equivs)
 237           (when equivs                  ; null for all non-Latin characters
 238             (dolist (ch1 equivs)
 239               (let ((vec (copy-sequence
 240                           (get-char-table ch1 latin-unity-equivalences)))
 241                     (ucs (latin-unity-char-to-unicode ch1)))
 242                 (when (and ucs (/= ucs -1)) (aset vec u+index ucs))
 243                 (dolist (ch2 equivs)
 244                   (let* ((cset (char-charset ch2))
 245                          (bit (get cset 'latin-unity-flag-bit))
 246                          (index (get cset 'latin-unity-index)))
 247                     (aset vec 0 (logior bit (aref vec 0)))
 248                     (aset vec index ch2)))
 249                 (put-char-table ch1 vec latin-unity-equivalences)))))
 250         unitable))
 251 )   ; when latin-unity-utils-found-unicode-support
 252
 253 (defun latin-unity-dump-tables ()
 254   "Create a Lisp library to initialize the equivalences char-table."
 255
 256   (interactive)
 257
 258   (if (not latin-unity-utils-found-unicode-support)
 259       (if (file-readable-p (expand-file-name "latin-unity-tables.el"))
 260           (message "Unicode unsupported.  Reusing old latin-unity-tables.el.")
 261         (error 'file-error
 262                "*** Can't find Unicode support or latin-unity-tables.el.***"))
 263
 264     ;; set up buffer
 265     (set-buffer (get-buffer-create "latin-unity-tables.el"))
 266     (erase-buffer)
 267
 268     ;; insert preface
 269     (let ((nilvec (make-vector (+ (length latin-unity-character-sets) 2) nil))
 270           (creation-date-string (format-time-string "%Y %B %d")))
 271       (insert ";;; latin-unity-tables.el ---"
 272               " initialize latin-unity-equivalences"
 273               "\n;; Do not edit --- automatically generated."
 274               "\n;; Created: " creation-date-string
 275               "\n(provide 'latin-unity-tables)"
 276               "\n(defconst latin-unity-equivalences"
 277               "\n  (let ((table (make-char-table 'generic)))"
 278               "\n    ;; default all non-Latin charsets"
 279               (format "\n    (put-char-table t %s table)"
 280                       (progn (aset nilvec 0 0) nilvec))
 281               "\n    ;; Control 1 code points are spatial"
 282               "\n    ;; Warning on these is beyond this library's scope."
 283               (format "\n    (put-char-table 'control-1 %s table)"
 284                       (progn (aset nilvec 0 latin-unity-all-flags) nilvec)))
 285
 286       ;; insert table insertions
 287       ;; alternate mmc: (format "(apply #'make-char '%s)" (split-char ch))
 288       (flet ((mmc (ch)
 289                (let ((x (split-char ch)))
 290                  (concat (format "(make-char '%s %d" (first x) (second x))
 291                          (if (third x) (format " %d)" (third x)) ")")))))
 292         (map-char-table
 293          (lambda (key val)
 294            (when (characterp key)
 295              (insert (format "\n    (put-char-table %s (vector %s) table)"
 296                              (mmc key)
 297                              (mapconcat
 298                               (lambda (elt)
 299                                 (cond ((characterp elt) (mmc elt))
 300                                       ((null elt) "nil")
 301                                       ;; be careful to emit read syntax here!
 302                                       ((integerp elt) (format "#x%X" elt))
 303                                       (t (format "%s" elt))))
 304                               val
 305                               " ")))))
 306          latin-unity-equivalences))
 307
 308       ;; insert trailing matter
 309       (insert "\n    table)"
 310               "\n  \"Map a (Latin) Mule character to the set of"
 311               " character sets containing it."
 312               "\nCreated: " creation-date-string "\")"
 313               "\n(put 'latin-unity-equivalences 'creation-date-string \""
 314               creation-date-string "\")"
 315               "\n;;; end of latin-unity-tables.el"
 316               "\n"))
 317
 318     ;; write the file
 319     (write-file "latin-unity-tables.el")
 320     (message "Wrote %s." "latin-unity-tables.el")))
 321
 322
 323 ;;; end of latin-unity-utils.el