| 1 | ;;; composite.el --- support character composition |
| 2 | |
| 3 | ;; Copyright (C) 2001-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, |
| 6 | ;; 2008, 2009, 2010, 2011 |
| 7 | ;; National Institute of Advanced Industrial Science and Technology (AIST) |
| 8 | ;; Registration Number H14PRO021 |
| 9 | |
| 10 | ;; Author: Kenichi HANDA <handa@etl.go.jp> |
| 11 | ;; (according to ack.texi) |
| 12 | ;; Keywords: mule, multilingual, character composition |
| 13 | ;; Package: emacs |
| 14 | |
| 15 | ;; This file is part of GNU Emacs. |
| 16 | |
| 17 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 18 | ;; it under the terms of the GNU General Public License as published by |
| 19 | ;; the Free Software Foundation, either version 3 of the License, or |
| 20 | ;; (at your option) any later version. |
| 21 | |
| 22 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 23 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 24 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 25 | ;; GNU General Public License for more details. |
| 26 | |
| 27 | ;; You should have received a copy of the GNU General Public License |
| 28 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 29 | |
| 30 | ;;; Commentary: |
| 31 | |
| 32 | ;;; Code: |
| 33 | |
| 34 | (defconst reference-point-alist |
| 35 | '((tl . 0) (tc . 1) (tr . 2) |
| 36 | (Bl . 3) (Bc . 4) (Br . 5) |
| 37 | (bl . 6) (bc . 7) (br . 8) |
| 38 | (cl . 9) (cc . 10) (cr . 11) |
| 39 | (top-left . 0) (top-center . 1) (top-right . 2) |
| 40 | (base-left . 3) (base-center . 4) (base-right . 5) |
| 41 | (bottom-left . 6) (bottom-center . 7) (bottom-right . 8) |
| 42 | (center-left . 9) (center-center . 10) (center-right . 11) |
| 43 | ;; For backward compatibility... |
| 44 | (ml . 3) (mc . 10) (mr . 5) |
| 45 | (mid-left . 3) (mid-center . 10) (mid-right . 5)) |
| 46 | "Alist of symbols vs integer codes of glyph reference points. |
| 47 | A glyph reference point symbol is to be used to specify a composition |
| 48 | rule in COMPONENTS argument to such functions as `compose-region'. |
| 49 | |
| 50 | The meaning of glyph reference point codes is as follows: |
| 51 | |
| 52 | 0----1----2 <---- ascent 0:tl or top-left |
| 53 | | | 1:tc or top-center |
| 54 | | | 2:tr or top-right |
| 55 | | | 3:Bl or base-left 9:cl or center-left |
| 56 | 9 10 11 <---- center 4:Bc or base-center 10:cc or center-center |
| 57 | | | 5:Br or base-right 11:cr or center-right |
| 58 | --3----4----5-- <-- baseline 6:bl or bottom-left |
| 59 | | | 7:bc or bottom-center |
| 60 | 6----7----8 <---- descent 8:br or bottom-right |
| 61 | |
| 62 | Glyph reference point symbols are to be used to specify a composition |
| 63 | rule of the form (GLOBAL-REF-POINT . NEW-REF-POINT), where |
| 64 | GLOBAL-REF-POINT is a reference point in the overall glyphs already |
| 65 | composed, and NEW-REF-POINT is a reference point in the new glyph to |
| 66 | be added. |
| 67 | |
| 68 | For instance, if GLOBAL-REF-POINT is `br' (bottom-right) and |
| 69 | NEW-REF-POINT is `tc' (top-center), the overall glyph is updated as |
| 70 | follows (the point `*' corresponds to both reference points): |
| 71 | |
| 72 | +-------+--+ <--- new ascent |
| 73 | | | | |
| 74 | | global| | |
| 75 | | glyph | | |
| 76 | -- | | |-- <--- baseline (doesn't change) |
| 77 | +----+--*--+ |
| 78 | | | new | |
| 79 | | |glyph| |
| 80 | +----+-----+ <--- new descent |
| 81 | |
| 82 | A composition rule may have the form (GLOBAL-REF-POINT |
| 83 | NEW-REF-POINT XOFF YOFF), where XOFF and YOFF specify how much |
| 84 | to shift NEW-REF-POINT from GLOBAL-REF-POINT. In this case, XOFF |
| 85 | and YOFF are integers in the range -100..100 representing the |
| 86 | shifting percentage against the font size.") |
| 87 | |
| 88 | |
| 89 | ;;;###autoload |
| 90 | (defun encode-composition-rule (rule) |
| 91 | "Encode composition rule RULE into an integer value. |
| 92 | RULE is a cons of global and new reference point symbols |
| 93 | \(see `reference-point-alist')." |
| 94 | |
| 95 | ;; This must be compatible with C macro COMPOSITION_ENCODE_RULE |
| 96 | ;; defined in composite.h. |
| 97 | |
| 98 | (if (and (integerp rule) (< rule 144)) |
| 99 | ;; Already encoded. |
| 100 | rule |
| 101 | (if (consp rule) |
| 102 | (let ((gref (car rule)) |
| 103 | (nref (cdr rule)) |
| 104 | xoff yoff) |
| 105 | (if (consp nref) ; (GREF NREF XOFF YOFF) |
| 106 | (progn |
| 107 | (setq xoff (nth 1 nref) |
| 108 | yoff (nth 2 nref) |
| 109 | nref (car nref)) |
| 110 | (or (and (>= xoff -100) (<= xoff 100) |
| 111 | (>= yoff -100) (<= yoff 100)) |
| 112 | (error "Invalid composition rule: %s" rule)) |
| 113 | (setq xoff (+ xoff 128) yoff (+ yoff 128))) |
| 114 | ;; (GREF . NREF) |
| 115 | (setq xoff 0 yoff 0)) |
| 116 | (or (integerp gref) |
| 117 | (setq gref (cdr (assq gref reference-point-alist)))) |
| 118 | (or (integerp nref) |
| 119 | (setq nref (cdr (assq nref reference-point-alist)))) |
| 120 | (or (and (>= gref 0) (< gref 12) (>= nref 0) (< nref 12)) |
| 121 | (error "Invalid composition rule: %S" rule)) |
| 122 | (logior (lsh xoff 16) (lsh yoff 8) (+ (* gref 12) nref))) |
| 123 | (error "Invalid composition rule: %S" rule)))) |
| 124 | |
| 125 | ;; Decode encoded composition rule RULE-CODE. The value is a cons of |
| 126 | ;; global and new reference point symbols. |
| 127 | ;; This must be compatible with C macro COMPOSITION_DECODE_RULE |
| 128 | ;; defined in composite.h. |
| 129 | |
| 130 | (defun decode-composition-rule (rule-code) |
| 131 | (or (and (natnump rule-code) (< rule-code #x1000000)) |
| 132 | (error "Invalid encoded composition rule: %S" rule-code)) |
| 133 | (let ((xoff (lsh rule-code -16)) |
| 134 | (yoff (logand (lsh rule-code -8) #xFF)) |
| 135 | gref nref) |
| 136 | (setq rule-code (logand rule-code #xFF) |
| 137 | gref (car (rassq (/ rule-code 12) reference-point-alist)) |
| 138 | nref (car (rassq (% rule-code 12) reference-point-alist))) |
| 139 | (or (and gref (symbolp gref) nref (symbolp nref)) |
| 140 | (error "Invalid composition rule code: %S" rule-code)) |
| 141 | (if (and (= xoff 0) (= yoff 0)) |
| 142 | (cons gref nref) |
| 143 | (setq xoff (- xoff 128) yoff (- yoff 128)) |
| 144 | (list gref xoff yoff nref)))) |
| 145 | |
| 146 | ;; Encode composition rules in composition components COMPONENTS. The |
| 147 | ;; value is a copy of COMPONENTS, where composition rules (cons of |
| 148 | ;; global and new glyph reference point symbols) are replaced with |
| 149 | ;; encoded composition rules. Optional 2nd argument NOCOPY non-nil |
| 150 | ;; means don't make a copy but modify COMPONENTS directly. |
| 151 | |
| 152 | (defun encode-composition-components (components &optional nocopy) |
| 153 | (or nocopy |
| 154 | (setq components (copy-sequence components))) |
| 155 | (if (vectorp components) |
| 156 | (let ((len (length components)) |
| 157 | (i 1)) |
| 158 | (while (< i len) |
| 159 | (aset components i |
| 160 | (encode-composition-rule (aref components i))) |
| 161 | (setq i (+ i 2)))) |
| 162 | (let ((tail (cdr components))) |
| 163 | (while tail |
| 164 | (setcar tail |
| 165 | (encode-composition-rule (car tail))) |
| 166 | (setq tail (nthcdr 2 tail))))) |
| 167 | components) |
| 168 | |
| 169 | ;; Decode composition rule codes in composition components COMPONENTS. |
| 170 | ;; The value is a copy of COMPONENTS, where composition rule codes are |
| 171 | ;; replaced with composition rules (cons of global and new glyph |
| 172 | ;; reference point symbols). Optional 2nd argument NOCOPY non-nil |
| 173 | ;; means don't make a copy but modify COMPONENTS directly. |
| 174 | ;; It is assumed that COMPONENTS is a vector and is for rule-base |
| 175 | ;; composition, thus (2N+1)th elements are rule codes. |
| 176 | |
| 177 | (defun decode-composition-components (components &optional nocopy) |
| 178 | (or nocopy |
| 179 | (setq components (copy-sequence components))) |
| 180 | (let ((len (length components)) |
| 181 | (i 1)) |
| 182 | (while (< i len) |
| 183 | (aset components i |
| 184 | (decode-composition-rule (aref components i))) |
| 185 | (setq i (+ i 2)))) |
| 186 | components) |
| 187 | |
| 188 | (defun compose-region (start end &optional components modification-func) |
| 189 | "Compose characters in the current region. |
| 190 | |
| 191 | Characters are composed relatively, i.e. composed by overstriking |
| 192 | or stacking depending on ascent, descent and other metrics of |
| 193 | glyphs. |
| 194 | |
| 195 | For instance, if the region has three characters \"XYZ\", X is |
| 196 | regarded as BASE glyph, and Y is displayed: |
| 197 | (1) above BASE if Y's descent value is not positive |
| 198 | (2) below BASE if Y's ascent value is not positive |
| 199 | (3) on BASE (i.e. at the BASE position) otherwise |
| 200 | and Z is displayed with the same rule while regarding the whole |
| 201 | XY glyphs as BASE. |
| 202 | |
| 203 | When called from a program, expects these four arguments. |
| 204 | |
| 205 | First two arguments START and END are positions (integers or markers) |
| 206 | specifying the region. |
| 207 | |
| 208 | Optional 3rd argument COMPONENTS, if non-nil, is a character, a string |
| 209 | or a vector or list of integers and rules. |
| 210 | |
| 211 | If it is a character, it is an alternate character to display instead |
| 212 | of the text in the region. |
| 213 | |
| 214 | If it is a string, the elements are alternate characters. In |
| 215 | this case, TAB element has a special meaning. If the first |
| 216 | character is TAB, the glyphs are displayed with left padding space |
| 217 | so that no pixel overlaps with the previous column. If the last |
| 218 | character is TAB, the glyphs are displayed with right padding |
| 219 | space so that no pixel overlaps with the following column. |
| 220 | |
| 221 | If it is a vector or list, it is a sequence of alternate characters and |
| 222 | composition rules, where (2N)th elements are characters and (2N+1)th |
| 223 | elements are composition rules to specify how to compose (2N+2)th |
| 224 | elements with previously composed N glyphs. |
| 225 | |
| 226 | A composition rule is a cons of global and new glyph reference point |
| 227 | symbols. See the documentation of `reference-point-alist' for more |
| 228 | details. |
| 229 | |
| 230 | Optional 4th argument MODIFICATION-FUNC is a function to call to |
| 231 | adjust the composition when it gets invalid because of a change of |
| 232 | text in the composition." |
| 233 | (interactive "r") |
| 234 | (let ((modified-p (buffer-modified-p)) |
| 235 | (inhibit-read-only t)) |
| 236 | (if (or (vectorp components) (listp components)) |
| 237 | (setq components (encode-composition-components components))) |
| 238 | (compose-region-internal start end components modification-func) |
| 239 | (restore-buffer-modified-p modified-p))) |
| 240 | |
| 241 | (defun decompose-region (start end) |
| 242 | "Decompose text in the current region. |
| 243 | |
| 244 | When called from a program, expects two arguments, |
| 245 | positions (integers or markers) specifying the region." |
| 246 | (interactive "r") |
| 247 | (let ((modified-p (buffer-modified-p)) |
| 248 | (inhibit-read-only t)) |
| 249 | (remove-text-properties start end '(composition nil)) |
| 250 | (restore-buffer-modified-p modified-p))) |
| 251 | |
| 252 | (defun compose-string (string &optional start end components modification-func) |
| 253 | "Compose characters in string STRING. |
| 254 | |
| 255 | The return value is STRING with the `composition' property put on all |
| 256 | the characters in it. |
| 257 | |
| 258 | Optional 2nd and 3rd arguments START and END specify the range of |
| 259 | STRING to be composed. They default to the beginning and the end of |
| 260 | STRING respectively. |
| 261 | |
| 262 | Optional 4th argument COMPONENTS, if non-nil, is a character or a |
| 263 | sequence (vector, list, or string) of integers. See the function |
| 264 | `compose-region' for more detail. |
| 265 | |
| 266 | Optional 5th argument MODIFICATION-FUNC is a function to call to |
| 267 | adjust the composition when it gets invalid because of a change of |
| 268 | text in the composition." |
| 269 | (if (or (vectorp components) (listp components)) |
| 270 | (setq components (encode-composition-components components))) |
| 271 | (or start (setq start 0)) |
| 272 | (or end (setq end (length string))) |
| 273 | (compose-string-internal string start end components modification-func) |
| 274 | string) |
| 275 | |
| 276 | (defun decompose-string (string) |
| 277 | "Return STRING where `composition' property is removed." |
| 278 | (remove-text-properties 0 (length string) '(composition nil) string) |
| 279 | string) |
| 280 | |
| 281 | (defun compose-chars (&rest args) |
| 282 | "Return a string from arguments in which all characters are composed. |
| 283 | For relative composition, arguments are characters. |
| 284 | For rule-based composition, Mth (where M is odd) arguments are |
| 285 | characters, and Nth (where N is even) arguments are composition rules. |
| 286 | A composition rule is a cons of glyph reference points of the form |
| 287 | \(GLOBAL-REF-POINT . NEW-REF-POINT). See the documentation of |
| 288 | `reference-point-alist' for more detail." |
| 289 | (let (str components) |
| 290 | (if (consp (car (cdr args))) |
| 291 | ;; Rule-base composition. |
| 292 | (let ((tail (encode-composition-components args 'nocopy))) |
| 293 | (while tail |
| 294 | (setq str (cons (car tail) str)) |
| 295 | (setq tail (nthcdr 2 tail))) |
| 296 | (setq str (concat (nreverse str)) |
| 297 | components args)) |
| 298 | ;; Relative composition. |
| 299 | (setq str (concat args))) |
| 300 | (compose-string-internal str 0 (length str) components))) |
| 301 | |
| 302 | (defun find-composition (pos &optional limit string detail-p) |
| 303 | "Return information about a composition at or near buffer position POS. |
| 304 | |
| 305 | If the character at POS has `composition' property, the value is a list |
| 306 | \(FROM TO VALID-P). |
| 307 | |
| 308 | FROM and TO specify the range of text that has the same `composition' |
| 309 | property, VALID-P is t if this composition is valid, and nil if not. |
| 310 | |
| 311 | If there's no composition at POS, and the optional 2nd argument LIMIT |
| 312 | is non-nil, search for a composition toward the position given by LIMIT. |
| 313 | |
| 314 | If no composition is found, return nil. |
| 315 | |
| 316 | Optional 3rd argument STRING, if non-nil, is a string to look for a |
| 317 | composition in; nil means the current buffer. |
| 318 | |
| 319 | If a valid composition is found and the optional 4th argument DETAIL-P |
| 320 | is non-nil, the return value is a list of the form |
| 321 | |
| 322 | (FROM TO COMPONENTS RELATIVE-P MOD-FUNC WIDTH) |
| 323 | |
| 324 | COMPONENTS is a vector of integers, the meaning depends on RELATIVE-P. |
| 325 | |
| 326 | RELATIVE-P is t if the composition method is relative, else nil. |
| 327 | |
| 328 | If RELATIVE-P is t, COMPONENTS is a vector of characters to be |
| 329 | composed. If RELATIVE-P is nil, COMPONENTS is a vector of characters |
| 330 | and composition rules as described in `compose-region'. |
| 331 | |
| 332 | MOD-FUNC is a modification function of the composition. |
| 333 | |
| 334 | WIDTH is a number of columns the composition occupies on the screen. |
| 335 | |
| 336 | When Automatic Composition mode is on, this function also finds a |
| 337 | chunk of text that is automatically composed. If such a chunk is |
| 338 | found closer to POS than the position that has `composition' |
| 339 | property, the value is a list of FROM, TO, and a glyph-string |
| 340 | that specifies how the chunk is to be composed. See the function |
| 341 | `composition-get-gstring' for the format of the glyph-string." |
| 342 | (let ((result (find-composition-internal pos limit string detail-p))) |
| 343 | (if (and detail-p (> (length result) 3) (nth 2 result) (not (nth 3 result))) |
| 344 | ;; This is a valid rule-base composition. |
| 345 | (decode-composition-components (nth 2 result) 'nocopy)) |
| 346 | result)) |
| 347 | |
| 348 | \f |
| 349 | (defun compose-chars-after (pos &optional limit object) |
| 350 | "Compose characters in current buffer after position POS. |
| 351 | |
| 352 | It looks up the char-table `composition-function-table' (which |
| 353 | see) by a character at POS, and compose characters after POS |
| 354 | according to the contents of `composition-function-table'. |
| 355 | |
| 356 | Optional 2nd arg LIMIT, if non-nil, limits characters to compose. |
| 357 | |
| 358 | Optional 3rd arg OBJECT, if non-nil, is a string that contains the |
| 359 | text to compose. In that case, POS and LIMIT index into the string. |
| 360 | |
| 361 | This function is the default value of `compose-chars-after-function'." |
| 362 | (let ((tail (aref composition-function-table (char-after pos))) |
| 363 | (font-obj (and (display-multi-font-p) |
| 364 | (and (not (stringp object)) |
| 365 | (font-at pos (selected-window))))) |
| 366 | pattern func result) |
| 367 | (or limit |
| 368 | (setq limit (if (stringp object) (length object) (point-max)))) |
| 369 | (when (and font-obj tail) |
| 370 | (save-match-data |
| 371 | (save-excursion |
| 372 | (while tail |
| 373 | (if (functionp (car tail)) |
| 374 | (setq pattern nil func (car tail)) |
| 375 | (setq pattern (car (car tail)) |
| 376 | func (cdr (car tail)))) |
| 377 | (goto-char pos) |
| 378 | (if pattern |
| 379 | (if (and (if (stringp object) |
| 380 | (eq (string-match pattern object) 0) |
| 381 | (looking-at pattern)) |
| 382 | (<= (match-end 0) limit)) |
| 383 | (setq result |
| 384 | (funcall func pos (match-end 0) font-obj object))) |
| 385 | (setq result (funcall func pos limit font-obj object))) |
| 386 | (if result (setq tail nil)))))) |
| 387 | result)) |
| 388 | |
| 389 | (defun compose-last-chars (args) |
| 390 | "Compose last characters. |
| 391 | The argument is a parameterized event of the form |
| 392 | (compose-last-chars N COMPONENTS), |
| 393 | where N is the number of characters before point to compose, |
| 394 | COMPONENTS, if non-nil, is the same as the argument to `compose-region' |
| 395 | \(which see). If it is nil, `compose-chars-after' is called, |
| 396 | and that function finds a proper rule to compose the target characters. |
| 397 | This function is intended to be used from input methods. |
| 398 | The global keymap binds special event `compose-last-chars' to this |
| 399 | function. Input method may generate an event (compose-last-chars N COMPONENTS) |
| 400 | after a sequence of character events." |
| 401 | (interactive "e") |
| 402 | (let ((chars (nth 1 args))) |
| 403 | (if (and (numberp chars) |
| 404 | (>= (- (point) (point-min)) chars)) |
| 405 | (if (nth 2 args) |
| 406 | (compose-region (- (point) chars) (point) (nth 2 args)) |
| 407 | (compose-chars-after (- (point) chars) (point)))))) |
| 408 | |
| 409 | (global-set-key [compose-last-chars] 'compose-last-chars) |
| 410 | |
| 411 | \f |
| 412 | ;;; Automatic character composition. |
| 413 | |
| 414 | ;; These macros must match with C macros LGSTRING_XXX and LGLYPH_XXX in font.h |
| 415 | (defsubst lgstring-header (gstring) (aref gstring 0)) |
| 416 | (defsubst lgstring-set-header (gstring header) (aset gstring 0 header)) |
| 417 | (defsubst lgstring-font (gstring) (aref (lgstring-header gstring) 0)) |
| 418 | (defsubst lgstring-char (gstring i) (aref (lgstring-header gstring) (1+ i))) |
| 419 | (defsubst lgstring-char-len (gstring) (1- (length (lgstring-header gstring)))) |
| 420 | (defsubst lgstring-shaped-p (gstring) (aref gstring 1)) |
| 421 | (defsubst lgstring-set-id (gstring id) (aset gstring 1 id)) |
| 422 | (defsubst lgstring-glyph (gstring i) (aref gstring (+ i 2))) |
| 423 | (defsubst lgstring-glyph-len (gstring) (- (length gstring) 2)) |
| 424 | (defsubst lgstring-set-glyph (gstring i glyph) (aset gstring (+ i 2) glyph)) |
| 425 | |
| 426 | (defsubst lglyph-from (glyph) (aref glyph 0)) |
| 427 | (defsubst lglyph-to (glyph) (aref glyph 1)) |
| 428 | (defsubst lglyph-char (glyph) (aref glyph 2)) |
| 429 | (defsubst lglyph-code (glyph) (aref glyph 3)) |
| 430 | (defsubst lglyph-width (glyph) (aref glyph 4)) |
| 431 | (defsubst lglyph-lbearing (glyph) (aref glyph 5)) |
| 432 | (defsubst lglyph-rbearing (glyph) (aref glyph 6)) |
| 433 | (defsubst lglyph-ascent (glyph) (aref glyph 7)) |
| 434 | (defsubst lglyph-descent (glyph) (aref glyph 8)) |
| 435 | (defsubst lglyph-adjustment (glyph) (aref glyph 9)) |
| 436 | |
| 437 | (defsubst lglyph-set-from-to (glyph from to) |
| 438 | (progn (aset glyph 0 from) (aset glyph 1 to))) |
| 439 | (defsubst lglyph-set-char (glyph char) (aset glyph 2 char)) |
| 440 | (defsubst lglyph-set-code (glyph code) (aset glyph 3 code)) |
| 441 | (defsubst lglyph-set-width (glyph width) (aset glyph 4 width)) |
| 442 | (defsubst lglyph-set-adjustment (glyph &optional xoff yoff wadjust) |
| 443 | (aset glyph 9 (vector (or xoff 0) (or yoff 0) (or wadjust 0)))) |
| 444 | |
| 445 | (defsubst lglyph-copy (glyph) (copy-sequence glyph)) |
| 446 | |
| 447 | (defun lgstring-insert-glyph (gstring idx glyph) |
| 448 | (let ((nglyphs (lgstring-glyph-len gstring)) |
| 449 | (i idx)) |
| 450 | (while (and (< i nglyphs) (lgstring-glyph gstring i)) |
| 451 | (setq i (1+ i))) |
| 452 | (if (= i nglyphs) |
| 453 | (setq gstring (vconcat gstring (vector glyph))) |
| 454 | (if (< (1+ i) nglyphs) |
| 455 | (lgstring-set-glyph gstring (1+ i) nil))) |
| 456 | (while (> i idx) |
| 457 | (lgstring-set-glyph gstring i (lgstring-glyph gstring (1- i))) |
| 458 | (setq i (1- i))) |
| 459 | (lgstring-set-glyph gstring i glyph) |
| 460 | gstring)) |
| 461 | |
| 462 | (defun compose-glyph-string (gstring from to) |
| 463 | (let ((glyph (lgstring-glyph gstring from)) |
| 464 | from-pos to-pos) |
| 465 | (setq from-pos (lglyph-from glyph) |
| 466 | to-pos (lglyph-to (lgstring-glyph gstring (1- to)))) |
| 467 | (lglyph-set-from-to glyph from-pos to-pos) |
| 468 | (setq from (1+ from)) |
| 469 | (while (and (< from to) |
| 470 | (setq glyph (lgstring-glyph gstring from))) |
| 471 | (lglyph-set-from-to glyph from-pos to-pos) |
| 472 | (let ((xoff (if (<= (lglyph-rbearing glyph) 0) 0 |
| 473 | (- (lglyph-width glyph))))) |
| 474 | (lglyph-set-adjustment glyph xoff 0 0)) |
| 475 | (setq from (1+ from))) |
| 476 | gstring)) |
| 477 | |
| 478 | (defun compose-glyph-string-relative (gstring from to &optional gap) |
| 479 | (let ((font-object (lgstring-font gstring)) |
| 480 | (glyph (lgstring-glyph gstring from)) |
| 481 | from-pos to-pos |
| 482 | ascent descent) |
| 483 | (if gap |
| 484 | (setq gap (floor (* (font-get font-object :size) gap))) |
| 485 | (setq gap 0)) |
| 486 | (setq from-pos (lglyph-from glyph) |
| 487 | to-pos (lglyph-to (lgstring-glyph gstring (1- to))) |
| 488 | ascent (lglyph-ascent glyph) |
| 489 | descent (lglyph-descent glyph)) |
| 490 | (lglyph-set-from-to glyph from-pos to-pos) |
| 491 | (setq from (1+ from)) |
| 492 | (while (< from to) |
| 493 | (setq glyph (lgstring-glyph gstring from)) |
| 494 | (lglyph-set-from-to glyph from-pos to-pos) |
| 495 | (let ((this-ascent (lglyph-ascent glyph)) |
| 496 | (this-descent (lglyph-descent glyph)) |
| 497 | xoff yoff) |
| 498 | (setq xoff (if (<= (lglyph-rbearing glyph) 0) 0 |
| 499 | (- (lglyph-width glyph)))) |
| 500 | (if (> this-ascent 0) |
| 501 | (if (< this-descent 0) |
| 502 | (setq yoff (- 0 ascent gap this-descent) |
| 503 | ascent (+ ascent gap this-ascent this-descent)) |
| 504 | (setq yoff 0)) |
| 505 | (setq yoff (+ descent gap this-ascent) |
| 506 | descent (+ descent gap this-ascent this-descent))) |
| 507 | (if (or (/= xoff 0) (/= yoff 0)) |
| 508 | (lglyph-set-adjustment glyph xoff yoff 0))) |
| 509 | (setq from (1+ from))) |
| 510 | gstring)) |
| 511 | |
| 512 | (defun compose-gstring-for-graphic (gstring) |
| 513 | "Compose glyph-string GSTRING for graphic display. |
| 514 | Combining characters are composed with the preceding base |
| 515 | character. If the preceding character is not a base character, |
| 516 | each combining character is composed as a spacing character by |
| 517 | a padding space before and/or after the character. |
| 518 | |
| 519 | All non-spacing characters have this function in |
| 520 | `composition-function-table' unless overwritten." |
| 521 | (let ((nchars (lgstring-char-len gstring)) |
| 522 | (nglyphs (lgstring-glyph-len gstring)) |
| 523 | (glyph (lgstring-glyph gstring 0))) |
| 524 | (cond |
| 525 | ;; A non-spacing character not following a proper base character. |
| 526 | ((= nchars 1) |
| 527 | (let ((lbearing (lglyph-lbearing glyph)) |
| 528 | (rbearing (lglyph-rbearing glyph)) |
| 529 | (width (lglyph-width glyph)) |
| 530 | xoff) |
| 531 | (if (< lbearing 0) |
| 532 | (setq xoff (- lbearing)) |
| 533 | (setq xoff 0 lbearing 0)) |
| 534 | (if (< rbearing width) |
| 535 | (setq rbearing width)) |
| 536 | (lglyph-set-adjustment glyph xoff 0 (- rbearing lbearing)) |
| 537 | gstring)) |
| 538 | |
| 539 | ;; This sequence doesn't start with a proper base character. |
| 540 | ((memq (get-char-code-property (lgstring-char gstring 0) |
| 541 | 'general-category) |
| 542 | '(Mn Mc Me Zs Zl Zp Cc Cf Cs)) |
| 543 | nil) |
| 544 | |
| 545 | ;; A base character and the following non-spacing characters. |
| 546 | (t |
| 547 | (let ((gstr (font-shape-gstring gstring))) |
| 548 | (if (and gstr |
| 549 | (> (lglyph-to (lgstring-glyph gstr 0)) 0)) |
| 550 | gstr |
| 551 | ;; The shaper of the font couldn't shape the gstring. |
| 552 | ;; Shape them according to canonical-combining-class. |
| 553 | (lgstring-set-id gstring nil) |
| 554 | (let* ((width (lglyph-width glyph)) |
| 555 | (ascent (lglyph-ascent glyph)) |
| 556 | (descent (lglyph-descent glyph)) |
| 557 | (rbearing (lglyph-rbearing glyph)) |
| 558 | (lbearing (lglyph-lbearing glyph)) |
| 559 | (center (/ (+ lbearing rbearing) 2)) |
| 560 | ;; Artificial vertical gap between the glyphs. |
| 561 | (gap (round (* (font-get (lgstring-font gstring) :size) 0.1)))) |
| 562 | (if (= gap 0) |
| 563 | ;; Assure at least 1 pixel vertical gap. |
| 564 | (setq gap 1)) |
| 565 | (dotimes (i nchars) |
| 566 | (setq glyph (lgstring-glyph gstring i)) |
| 567 | (when (> i 0) |
| 568 | (let* ((class (get-char-code-property |
| 569 | (lglyph-char glyph) 'canonical-combining-class)) |
| 570 | (lb (lglyph-lbearing glyph)) |
| 571 | (rb (lglyph-rbearing glyph)) |
| 572 | (as (lglyph-ascent glyph)) |
| 573 | (de (lglyph-descent glyph)) |
| 574 | (ce (/ (+ lb rb) 2)) |
| 575 | (w (lglyph-width glyph)) |
| 576 | xoff yoff) |
| 577 | (cond |
| 578 | ((and class (>= class 200) (<= class 240)) |
| 579 | (setq xoff 0 yoff 0) |
| 580 | (cond |
| 581 | ((= class 200) |
| 582 | (setq xoff (- lbearing ce) |
| 583 | yoff (if (> as 0) 0 (+ descent as)))) |
| 584 | ((= class 202) |
| 585 | (if (> as 0) (setq as 0)) |
| 586 | (setq xoff (- center ce) |
| 587 | yoff (if (> as 0) 0 (+ descent as)))) |
| 588 | ((= class 204) |
| 589 | (if (> as 0) (setq as 0)) |
| 590 | (setq xoff (- rbearing ce) |
| 591 | yoff (if (> as 0) 0 (+ descent as)))) |
| 592 | ((= class 208) |
| 593 | (setq xoff (- lbearing rb))) |
| 594 | ((= class 210) |
| 595 | (setq xoff (- rbearing lb))) |
| 596 | ((= class 212) |
| 597 | (setq xoff (- lbearing ce) |
| 598 | yoff (if (>= de 0) 0 (- (- ascent) de)))) |
| 599 | ((= class 214) |
| 600 | (setq xoff (- center ce) |
| 601 | yoff (if (>= de 0) 0 (- (- ascent) de)))) |
| 602 | ((= class 216) |
| 603 | (setq xoff (- rbearing ce) |
| 604 | yoff (if (>= de 0) 0 (- (- ascent) de)))) |
| 605 | ((= class 218) |
| 606 | (setq xoff (- lbearing ce) |
| 607 | yoff (if (> as 0) 0 (+ descent as gap)))) |
| 608 | ((= class 220) |
| 609 | (setq xoff (- center ce) |
| 610 | yoff (if (> as 0) 0 (+ descent as gap)))) |
| 611 | ((= class 222) |
| 612 | (setq xoff (- rbearing ce) |
| 613 | yoff (if (> as 0) 0 (+ descent as gap)))) |
| 614 | ((= class 224) |
| 615 | (setq xoff (- lbearing rb))) |
| 616 | ((= class 226) |
| 617 | (setq xoff (- rbearing lb))) |
| 618 | ((= class 228) |
| 619 | (setq xoff (- lbearing ce) |
| 620 | yoff (if (>= de 0) 0 (- (- ascent) de gap)))) |
| 621 | ((= class 230) |
| 622 | (setq xoff (- center ce) |
| 623 | yoff (if (>= de 0) 0 (- (- ascent) de gap)))) |
| 624 | ((= class 232) |
| 625 | (setq xoff (- rbearing ce) |
| 626 | yoff (if (>= de 0) 0 (- (+ ascent de) gap))))) |
| 627 | (lglyph-set-adjustment glyph (- xoff width) yoff) |
| 628 | (setq lb (+ lb xoff) |
| 629 | rb (+ lb xoff) |
| 630 | as (- as yoff) |
| 631 | de (+ de yoff))) |
| 632 | ((and (= class 0) |
| 633 | (eq (get-char-code-property (lglyph-char glyph) |
| 634 | 'general-category) 'Me)) |
| 635 | ;; Artificially laying out glyphs in an enclosing |
| 636 | ;; mark is difficult. All we can do is to adjust |
| 637 | ;; the x-offset and width of the base glyph to |
| 638 | ;; align it at the center of the glyph of the |
| 639 | ;; enclosing mark hoping that the enclosing mark |
| 640 | ;; is big enough. We also have to adjust the |
| 641 | ;; x-offset and width of the mark ifself properly |
| 642 | ;; depending on how the glyph is designed. |
| 643 | |
| 644 | ;; (non-spacing or not). For instance, when we |
| 645 | ;; have these glyphs: |
| 646 | ;; X position | |
| 647 | ;; base: <-*-> lbearing=0 rbearing=5 width=5 |
| 648 | ;; mark: <----------.> lb=-11 rb=2 w=0 |
| 649 | ;; we get a correct layout by moving them as this: |
| 650 | ;; base: <-*-> XOFF=4 WAD=9 |
| 651 | ;; mark: <----------.> xoff=2 wad=4 |
| 652 | ;; we have moved the base to the left by 4-pixel |
| 653 | ;; and make its width 9-pixel, then move the mark |
| 654 | ;; to the left 2-pixel and make its width 4-pixel. |
| 655 | (let* (;; Adjustment for the base glyph |
| 656 | (XOFF (/ (- rb lb width) 2)) |
| 657 | (WAD (+ width XOFF)) |
| 658 | ;; Adjustment for the enclosing mark glyph |
| 659 | (xoff (- (+ lb WAD))) |
| 660 | (wad (- rb lb WAD))) |
| 661 | (lglyph-set-adjustment glyph xoff 0 wad) |
| 662 | (setq glyph (lgstring-glyph gstring 0)) |
| 663 | (lglyph-set-adjustment glyph XOFF 0 WAD)))) |
| 664 | (if (< ascent as) |
| 665 | (setq ascent as)) |
| 666 | (if (< descent de) |
| 667 | (setq descent de)))))) |
| 668 | (let ((i 0)) |
| 669 | (while (and (< i nglyphs) (setq glyph (lgstring-glyph gstring i))) |
| 670 | (lglyph-set-from-to glyph 0 (1- nchars)) |
| 671 | (setq i (1+ i)))) |
| 672 | gstring)))))) |
| 673 | |
| 674 | ;; Allow for bootstrapping without uni-*.el. |
| 675 | (when unicode-category-table |
| 676 | (let ((elt `([,(purecopy "\\c.\\c^+") 1 compose-gstring-for-graphic] |
| 677 | [nil 0 compose-gstring-for-graphic]))) |
| 678 | (map-char-table |
| 679 | #'(lambda (key val) |
| 680 | (if (memq val '(Mn Mc Me)) |
| 681 | (set-char-table-range composition-function-table key elt))) |
| 682 | unicode-category-table))) |
| 683 | |
| 684 | (defun compose-gstring-for-terminal (gstring) |
| 685 | "Compose glyph-string GSTRING for terminal display. |
| 686 | Non-spacing characters are composed with the preceding base |
| 687 | character. If the preceding character is not a base character, |
| 688 | each non-spacing character is composed as a spacing character by |
| 689 | prepending a space before it." |
| 690 | (let ((nglyphs (lgstring-glyph-len gstring)) |
| 691 | (i 0) |
| 692 | (coding (lgstring-font gstring)) |
| 693 | glyph) |
| 694 | (while (and (< i nglyphs) |
| 695 | (setq glyph (lgstring-glyph gstring i))) |
| 696 | (if (not (char-charset (lglyph-char glyph) coding)) |
| 697 | (progn |
| 698 | ;; As the terminal doesn't support this glyph, return a |
| 699 | ;; gstring in which each glyph is its own grapheme-cluster |
| 700 | ;; of width 1.. |
| 701 | (setq i 0) |
| 702 | (while (and (< i nglyphs) |
| 703 | (setq glyph (lgstring-glyph gstring i))) |
| 704 | (if (< (lglyph-width glyph) 1) |
| 705 | (lglyph-set-width glyph 1)) |
| 706 | (lglyph-set-from-to glyph i i) |
| 707 | (setq i (1+ i)))) |
| 708 | (if (= (lglyph-width glyph) 0) |
| 709 | (if (eq (get-char-code-property (lglyph-char glyph) |
| 710 | 'general-category) |
| 711 | 'Cf) |
| 712 | (progn |
| 713 | ;; Compose by replacing with a space. |
| 714 | (lglyph-set-char glyph 32) |
| 715 | (lglyph-set-width glyph 1) |
| 716 | (setq i (1+ i))) |
| 717 | ;; Compose by prepending a space. |
| 718 | (setq gstring (lgstring-insert-glyph gstring i |
| 719 | (lglyph-copy glyph)) |
| 720 | nglyphs (lgstring-glyph-len gstring)) |
| 721 | (setq glyph (lgstring-glyph gstring i)) |
| 722 | (lglyph-set-char glyph 32) |
| 723 | (lglyph-set-width glyph 1) |
| 724 | (setq i (+ 2))) |
| 725 | (let ((from (lglyph-from glyph)) |
| 726 | (to (lglyph-to glyph)) |
| 727 | (j (1+ i))) |
| 728 | (while (and (< j nglyphs) |
| 729 | (setq glyph (lgstring-glyph gstring j)) |
| 730 | (char-charset (lglyph-char glyph) coding) |
| 731 | (= (lglyph-width glyph) 0)) |
| 732 | (setq to (lglyph-to glyph) |
| 733 | j (1+ j))) |
| 734 | (while (< i j) |
| 735 | (setq glyph (lgstring-glyph gstring i)) |
| 736 | (lglyph-set-from-to glyph from to) |
| 737 | (setq i (1+ i))))))) |
| 738 | gstring)) |
| 739 | |
| 740 | |
| 741 | (defun auto-compose-chars (func from to font-object string) |
| 742 | "Compose the characters at FROM by FUNC. |
| 743 | FUNC is called with one argument GSTRING which is built for characters |
| 744 | in the region FROM (inclusive) and TO (exclusive). |
| 745 | |
| 746 | If the character are composed on a graphic display, FONT-OBJECT |
| 747 | is a font to use. Otherwise, FONT-OBJECT is nil, and the function |
| 748 | `compose-gstring-for-terminal' is used instead of FUNC. |
| 749 | |
| 750 | If STRING is non-nil, it is a string, and FROM and TO are indices |
| 751 | into the string. In that case, compose characters in the string. |
| 752 | |
| 753 | The value is a gstring containing information for shaping the characters. |
| 754 | |
| 755 | This function is the default value of `auto-composition-function' (which see)." |
| 756 | (let ((gstring (composition-get-gstring from to font-object string))) |
| 757 | (if (lgstring-shaped-p gstring) |
| 758 | gstring |
| 759 | (or (fontp font-object 'font-object) |
| 760 | (setq func 'compose-gstring-for-terminal)) |
| 761 | (funcall func gstring)))) |
| 762 | |
| 763 | (put 'auto-composition-mode 'permanent-local t) |
| 764 | |
| 765 | (make-variable-buffer-local 'auto-composition-function) |
| 766 | (setq-default auto-composition-function 'auto-compose-chars) |
| 767 | |
| 768 | ;;;###autoload |
| 769 | (define-minor-mode auto-composition-mode |
| 770 | "Toggle Auto Composition mode. |
| 771 | With a prefix argument ARG, enable Auto Composition mode if ARG |
| 772 | is positive, and disable it otherwise. If called from Lisp, |
| 773 | enable the mode if ARG is omitted or nil. |
| 774 | |
| 775 | When Auto Composition mode is enabled, text characters are |
| 776 | automatically composed by functions registered in |
| 777 | `composition-function-table'. |
| 778 | |
| 779 | You can use `global-auto-composition-mode' to turn on |
| 780 | Auto Composition mode in all buffers (this is the default)." |
| 781 | ;; It's defined in C, this stops the d-m-m macro defining it again. |
| 782 | :variable auto-composition-mode) |
| 783 | ;; It's not defined with DEFVAR_PER_BUFFER though. |
| 784 | (make-variable-buffer-local 'auto-composition-mode) |
| 785 | |
| 786 | ;;;###autoload |
| 787 | (define-minor-mode global-auto-composition-mode |
| 788 | "Toggle Auto Composition mode in all buffers. |
| 789 | With a prefix argument ARG, enable it if ARG is positive, and |
| 790 | disable it otherwise. If called from Lisp, enable it if ARG is |
| 791 | omitted or nil. |
| 792 | |
| 793 | For more information on Auto Composition mode, see |
| 794 | `auto-composition-mode' ." |
| 795 | :variable (default-value 'auto-composition-mode)) |
| 796 | |
| 797 | (defalias 'toggle-auto-composition 'auto-composition-mode) |
| 798 | |
| 799 | \f |
| 800 | |
| 801 | ;;; composite.el ends here |