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