Line data Source code
1 : ;;; composite.el --- support character composition
2 :
3 : ;; Copyright (C) 2001-2017 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 0 : (if (and (integerp rule) (< rule 144))
99 : ;; Already encoded.
100 0 : rule
101 0 : (if (consp rule)
102 0 : (let ((gref (car rule))
103 0 : (nref (cdr rule))
104 : xoff yoff)
105 0 : (if (consp nref) ; (GREF NREF XOFF YOFF)
106 0 : (progn
107 0 : (setq xoff (nth 1 nref)
108 0 : yoff (nth 2 nref)
109 0 : nref (car nref))
110 0 : (or (and (>= xoff -100) (<= xoff 100)
111 0 : (>= yoff -100) (<= yoff 100))
112 0 : (error "Invalid composition rule: %s" rule))
113 0 : (setq xoff (+ xoff 128) yoff (+ yoff 128)))
114 : ;; (GREF . NREF)
115 0 : (setq xoff 0 yoff 0))
116 0 : (or (integerp gref)
117 0 : (setq gref (cdr (assq gref reference-point-alist))))
118 0 : (or (integerp nref)
119 0 : (setq nref (cdr (assq nref reference-point-alist))))
120 0 : (or (and (>= gref 0) (< gref 12) (>= nref 0) (< nref 12))
121 0 : (error "Invalid composition rule: %S" rule))
122 0 : (logior (lsh xoff 16) (lsh yoff 8) (+ (* gref 12) nref)))
123 0 : (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 0 : (or (and (natnump rule-code) (< rule-code #x1000000))
132 0 : (error "Invalid encoded composition rule: %S" rule-code))
133 0 : (let ((xoff (lsh rule-code -16))
134 0 : (yoff (logand (lsh rule-code -8) #xFF))
135 : gref nref)
136 0 : (setq rule-code (logand rule-code #xFF)
137 0 : gref (car (rassq (/ rule-code 12) reference-point-alist))
138 0 : nref (car (rassq (% rule-code 12) reference-point-alist)))
139 0 : (or (and gref (symbolp gref) nref (symbolp nref))
140 0 : (error "Invalid composition rule code: %S" rule-code))
141 0 : (if (and (= xoff 0) (= yoff 0))
142 0 : (cons gref nref)
143 0 : (setq xoff (- xoff 128) yoff (- yoff 128))
144 0 : (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 0 : (or nocopy
154 0 : (setq components (copy-sequence components)))
155 0 : (if (vectorp components)
156 0 : (let ((len (length components))
157 : (i 1))
158 0 : (while (< i len)
159 0 : (aset components i
160 0 : (encode-composition-rule (aref components i)))
161 0 : (setq i (+ i 2))))
162 0 : (let ((tail (cdr components)))
163 0 : (while tail
164 0 : (setcar tail
165 0 : (encode-composition-rule (car tail)))
166 0 : (setq tail (nthcdr 2 tail)))))
167 0 : 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 0 : (or nocopy
179 0 : (setq components (copy-sequence components)))
180 0 : (let ((len (length components))
181 : (i 1))
182 0 : (while (< i len)
183 0 : (aset components i
184 0 : (decode-composition-rule (aref components i)))
185 0 : (setq i (+ i 2))))
186 0 : 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 0 : (let ((modified-p (buffer-modified-p))
235 : (inhibit-read-only t))
236 0 : (if (or (vectorp components) (listp components))
237 0 : (setq components (encode-composition-components components)))
238 0 : (compose-region-internal start end components modification-func)
239 0 : (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 0 : (let ((modified-p (buffer-modified-p))
248 : (inhibit-read-only t))
249 0 : (remove-text-properties start end '(composition nil))
250 0 : (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 0 : (if (or (vectorp components) (listp components))
270 0 : (setq components (encode-composition-components components)))
271 0 : (or start (setq start 0))
272 0 : (or end (setq end (length string)))
273 0 : (compose-string-internal string start end components modification-func)
274 0 : string)
275 :
276 : (defun decompose-string (string)
277 : "Return STRING where `composition' property is removed."
278 0 : (remove-text-properties 0 (length string) '(composition nil) string)
279 0 : 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 0 : (let (str components)
290 0 : (if (consp (car (cdr args)))
291 : ;; Rule-base composition.
292 0 : (let ((tail (encode-composition-components args 'nocopy)))
293 0 : (while tail
294 0 : (setq str (cons (car tail) str))
295 0 : (setq tail (nthcdr 2 tail)))
296 0 : (setq str (concat (nreverse str))
297 0 : components args))
298 : ;; Relative composition.
299 0 : (setq str (concat args)))
300 0 : (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 0 : (let ((result (find-composition-internal pos limit string detail-p)))
343 0 : (if (and detail-p (> (length result) 3) (nth 2 result) (not (nth 3 result)))
344 : ;; This is a valid rule-base composition.
345 0 : (decode-composition-components (nth 2 result) 'nocopy))
346 0 : result))
347 :
348 :
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 0 : (let ((tail (aref composition-function-table (char-after pos)))
363 0 : (font-obj (and (display-multi-font-p)
364 0 : (and (not (stringp object))
365 0 : (font-at pos (selected-window)))))
366 : pattern func result)
367 0 : (or limit
368 0 : (setq limit (if (stringp object) (length object) (point-max))))
369 0 : (when (and font-obj tail)
370 0 : (save-match-data
371 0 : (save-excursion
372 0 : (while tail
373 0 : (if (functionp (car tail))
374 0 : (setq pattern nil func (car tail))
375 0 : (setq pattern (car (car tail))
376 0 : func (cdr (car tail))))
377 0 : (goto-char pos)
378 0 : (if pattern
379 0 : (if (and (if (stringp object)
380 0 : (eq (string-match pattern object) 0)
381 0 : (looking-at pattern))
382 0 : (<= (match-end 0) limit))
383 0 : (setq result
384 0 : (funcall func pos (match-end 0) font-obj object)))
385 0 : (setq result (funcall func pos limit font-obj object)))
386 0 : (if result (setq tail nil))))))
387 0 : 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 0 : (let ((chars (nth 1 args)))
403 0 : (if (and (numberp chars)
404 0 : (>= (- (point) (point-min)) chars))
405 0 : (if (nth 2 args)
406 0 : (compose-region (- (point) chars) (point) (nth 2 args))
407 0 : (compose-chars-after (- (point) chars) (point))))))
408 :
409 : (global-set-key [compose-last-chars] 'compose-last-chars)
410 :
411 :
412 : ;;; Automatic character composition.
413 :
414 : ;; These macros must match with C macros LGSTRING_XXX and LGLYPH_XXX in font.h
415 0 : (defsubst lgstring-header (gstring) (aref gstring 0))
416 0 : (defsubst lgstring-set-header (gstring header) (aset gstring 0 header))
417 0 : (defsubst lgstring-font (gstring) (aref (lgstring-header gstring) 0))
418 0 : (defsubst lgstring-char (gstring i) (aref (lgstring-header gstring) (1+ i)))
419 0 : (defsubst lgstring-char-len (gstring) (1- (length (lgstring-header gstring))))
420 0 : (defsubst lgstring-shaped-p (gstring) (aref gstring 1))
421 0 : (defsubst lgstring-set-id (gstring id) (aset gstring 1 id))
422 0 : (defsubst lgstring-glyph (gstring i) (aref gstring (+ i 2)))
423 0 : (defsubst lgstring-glyph-len (gstring) (- (length gstring) 2))
424 0 : (defsubst lgstring-set-glyph (gstring i glyph) (aset gstring (+ i 2) glyph))
425 :
426 0 : (defsubst lglyph-from (glyph) (aref glyph 0))
427 0 : (defsubst lglyph-to (glyph) (aref glyph 1))
428 0 : (defsubst lglyph-char (glyph) (aref glyph 2))
429 0 : (defsubst lglyph-code (glyph) (aref glyph 3))
430 0 : (defsubst lglyph-width (glyph) (aref glyph 4))
431 0 : (defsubst lglyph-lbearing (glyph) (aref glyph 5))
432 0 : (defsubst lglyph-rbearing (glyph) (aref glyph 6))
433 0 : (defsubst lglyph-ascent (glyph) (aref glyph 7))
434 0 : (defsubst lglyph-descent (glyph) (aref glyph 8))
435 0 : (defsubst lglyph-adjustment (glyph) (aref glyph 9))
436 :
437 : (defsubst lglyph-set-from-to (glyph from to)
438 0 : (progn (aset glyph 0 from) (aset glyph 1 to)))
439 0 : (defsubst lglyph-set-char (glyph char) (aset glyph 2 char))
440 0 : (defsubst lglyph-set-code (glyph code) (aset glyph 3 code))
441 0 : (defsubst lglyph-set-width (glyph width) (aset glyph 4 width))
442 : (defsubst lglyph-set-adjustment (glyph &optional xoff yoff wadjust)
443 0 : (aset glyph 9 (vector (or xoff 0) (or yoff 0) (or wadjust 0))))
444 :
445 0 : (defsubst lglyph-copy (glyph) (copy-sequence glyph))
446 :
447 : (defun lgstring-insert-glyph (gstring idx glyph)
448 0 : (let ((nglyphs (lgstring-glyph-len gstring))
449 0 : (i idx))
450 0 : (while (and (< i nglyphs) (lgstring-glyph gstring i))
451 0 : (setq i (1+ i)))
452 0 : (if (= i nglyphs)
453 0 : (setq gstring (vconcat gstring (vector glyph)))
454 0 : (if (< (1+ i) nglyphs)
455 0 : (lgstring-set-glyph gstring (1+ i) nil)))
456 0 : (while (> i idx)
457 0 : (lgstring-set-glyph gstring i (lgstring-glyph gstring (1- i)))
458 0 : (setq i (1- i)))
459 0 : (lgstring-set-glyph gstring i glyph)
460 0 : gstring))
461 :
462 : (defun compose-glyph-string (gstring from to)
463 0 : (let ((glyph (lgstring-glyph gstring from))
464 : from-pos to-pos)
465 0 : (setq from-pos (lglyph-from glyph)
466 0 : to-pos (lglyph-to (lgstring-glyph gstring (1- to))))
467 0 : (lglyph-set-from-to glyph from-pos to-pos)
468 0 : (setq from (1+ from))
469 0 : (while (and (< from to)
470 0 : (setq glyph (lgstring-glyph gstring from)))
471 0 : (lglyph-set-from-to glyph from-pos to-pos)
472 0 : (let ((xoff (if (<= (lglyph-rbearing glyph) 0) 0
473 0 : (- (lglyph-width glyph)))))
474 0 : (lglyph-set-adjustment glyph xoff 0 0))
475 0 : (setq from (1+ from)))
476 0 : gstring))
477 :
478 : (defun compose-glyph-string-relative (gstring from to &optional gap)
479 0 : (let ((font-object (lgstring-font gstring))
480 0 : (glyph (lgstring-glyph gstring from))
481 : from-pos to-pos
482 : ascent descent)
483 0 : (if gap
484 0 : (setq gap (floor (* (font-get font-object :size) gap)))
485 0 : (setq gap 0))
486 0 : (setq from-pos (lglyph-from glyph)
487 0 : to-pos (lglyph-to (lgstring-glyph gstring (1- to)))
488 0 : ascent (lglyph-ascent glyph)
489 0 : descent (lglyph-descent glyph))
490 0 : (lglyph-set-from-to glyph from-pos to-pos)
491 0 : (setq from (1+ from))
492 0 : (while (< from to)
493 0 : (setq glyph (lgstring-glyph gstring from))
494 0 : (lglyph-set-from-to glyph from-pos to-pos)
495 0 : (let ((this-ascent (lglyph-ascent glyph))
496 0 : (this-descent (lglyph-descent glyph))
497 : xoff yoff)
498 0 : (setq xoff (if (<= (lglyph-rbearing glyph) 0) 0
499 0 : (- (lglyph-width glyph))))
500 0 : (if (> this-ascent 0)
501 0 : (if (< this-descent 0)
502 0 : (setq yoff (- 0 ascent gap this-descent)
503 0 : ascent (+ ascent gap this-ascent this-descent))
504 0 : (setq yoff 0))
505 0 : (setq yoff (+ descent gap this-ascent)
506 0 : descent (+ descent gap this-ascent this-descent)))
507 0 : (if (or (/= xoff 0) (/= yoff 0))
508 0 : (lglyph-set-adjustment glyph xoff yoff 0)))
509 0 : (setq from (1+ from)))
510 0 : 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 0 : (let ((nchars (lgstring-char-len gstring))
522 0 : (nglyphs (lgstring-glyph-len gstring))
523 0 : (glyph (lgstring-glyph gstring 0)))
524 0 : (cond
525 : ;; A non-spacing character not following a proper base character.
526 0 : ((= nchars 1)
527 0 : (let ((lbearing (lglyph-lbearing glyph))
528 0 : (rbearing (lglyph-rbearing glyph))
529 0 : (width (lglyph-width glyph))
530 : xoff)
531 0 : (if (< lbearing 0)
532 0 : (setq xoff (- lbearing))
533 0 : (setq xoff 0 lbearing 0))
534 0 : (if (< rbearing width)
535 0 : (setq rbearing width))
536 0 : (lglyph-set-adjustment glyph xoff 0 (- rbearing lbearing))
537 0 : gstring))
538 :
539 : ;; This sequence doesn't start with a proper base character.
540 0 : ((memq (get-char-code-property (lgstring-char gstring 0)
541 0 : 'general-category)
542 0 : '(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 0 : (let ((gstr (font-shape-gstring gstring)))
548 0 : (if (and gstr
549 0 : (> (lglyph-to (lgstring-glyph gstr 0)) 0))
550 0 : gstr
551 : ;; The shaper of the font couldn't shape the gstring.
552 : ;; Shape them according to canonical-combining-class.
553 0 : (lgstring-set-id gstring nil)
554 0 : (let* ((width (lglyph-width glyph))
555 0 : (ascent (lglyph-ascent glyph))
556 0 : (descent (lglyph-descent glyph))
557 0 : (rbearing (lglyph-rbearing glyph))
558 0 : (lbearing (lglyph-lbearing glyph))
559 0 : (center (/ (+ lbearing rbearing) 2))
560 : ;; Artificial vertical gap between the glyphs.
561 0 : (gap (round (* (font-get (lgstring-font gstring) :size) 0.1))))
562 0 : (if (= gap 0)
563 : ;; Assure at least 1 pixel vertical gap.
564 0 : (setq gap 1))
565 0 : (dotimes (i nchars)
566 0 : (setq glyph (lgstring-glyph gstring i))
567 0 : (when (> i 0)
568 0 : (let* ((class (get-char-code-property
569 0 : (lglyph-char glyph) 'canonical-combining-class))
570 0 : (lb (lglyph-lbearing glyph))
571 0 : (rb (lglyph-rbearing glyph))
572 0 : (as (lglyph-ascent glyph))
573 0 : (de (lglyph-descent glyph))
574 0 : (ce (/ (+ lb rb) 2))
575 0 : (w (lglyph-width glyph))
576 : xoff yoff)
577 0 : (cond
578 0 : ((and class (>= class 200) (<= class 240))
579 0 : (setq xoff 0 yoff 0)
580 0 : (cond
581 0 : ((= class 200)
582 0 : (setq xoff (- lbearing ce)
583 0 : yoff (if (> as 0) 0 (+ descent as))))
584 0 : ((= class 202)
585 0 : (if (> as 0) (setq as 0))
586 0 : (setq xoff (- center ce)
587 0 : yoff (if (> as 0) 0 (+ descent as))))
588 0 : ((= class 204)
589 0 : (if (> as 0) (setq as 0))
590 0 : (setq xoff (- rbearing ce)
591 0 : yoff (if (> as 0) 0 (+ descent as))))
592 0 : ((= class 208)
593 0 : (setq xoff (- lbearing rb)))
594 0 : ((= class 210)
595 0 : (setq xoff (- rbearing lb)))
596 0 : ((= class 212)
597 0 : (setq xoff (- lbearing ce)
598 0 : yoff (if (>= de 0) 0 (- (- ascent) de))))
599 0 : ((= class 214)
600 0 : (setq xoff (- center ce)
601 0 : yoff (if (>= de 0) 0 (- (- ascent) de))))
602 0 : ((= class 216)
603 0 : (setq xoff (- rbearing ce)
604 0 : yoff (if (>= de 0) 0 (- (- ascent) de))))
605 0 : ((= class 218)
606 0 : (setq xoff (- lbearing ce)
607 0 : yoff (if (> as 0) 0 (+ descent as gap))))
608 0 : ((= class 220)
609 0 : (setq xoff (- center ce)
610 0 : yoff (if (> as 0) 0 (+ descent as gap))))
611 0 : ((= class 222)
612 0 : (setq xoff (- rbearing ce)
613 0 : yoff (if (> as 0) 0 (+ descent as gap))))
614 0 : ((= class 224)
615 0 : (setq xoff (- lbearing rb)))
616 0 : ((= class 226)
617 0 : (setq xoff (- rbearing lb)))
618 0 : ((= class 228)
619 0 : (setq xoff (- lbearing ce)
620 0 : yoff (if (>= de 0) 0 (- (- ascent) de gap))))
621 0 : ((= class 230)
622 0 : (setq xoff (- center ce)
623 0 : yoff (if (>= de 0) 0 (- (- ascent) de gap))))
624 0 : ((= class 232)
625 0 : (setq xoff (- rbearing ce)
626 0 : yoff (if (>= de 0) 0 (- (+ ascent de) gap)))))
627 0 : (lglyph-set-adjustment glyph (- xoff width) yoff)
628 0 : (setq lb (+ lb xoff)
629 0 : rb (+ lb xoff)
630 0 : as (- as yoff)
631 0 : de (+ de yoff)))
632 0 : ((and (= class 0)
633 0 : (eq (get-char-code-property (lglyph-char glyph)
634 0 : '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 0 : (let* (;; Adjustment for the base glyph
656 0 : (XOFF (/ (- rb lb width) 2))
657 0 : (WAD (+ width XOFF))
658 : ;; Adjustment for the enclosing mark glyph
659 0 : (xoff (- (+ lb WAD)))
660 0 : (wad (- rb lb WAD)))
661 0 : (lglyph-set-adjustment glyph xoff 0 wad)
662 0 : (setq glyph (lgstring-glyph gstring 0))
663 0 : (lglyph-set-adjustment glyph XOFF 0 WAD))))
664 0 : (if (< ascent as)
665 0 : (setq ascent as))
666 0 : (if (< descent de)
667 0 : (setq descent de))))))
668 0 : (let ((i 0))
669 0 : (while (and (< i nglyphs) (setq glyph (lgstring-glyph gstring i)))
670 0 : (lglyph-set-from-to glyph 0 (1- nchars))
671 0 : (setq i (1+ i))))
672 0 : gstring))))))
673 :
674 : (defun compose-gstring-for-dotted-circle (gstring)
675 0 : (let* ((dc (lgstring-glyph gstring 0)) ; glyph of dotted-circle
676 0 : (dc-id (lglyph-code dc))
677 0 : (fc (lgstring-glyph gstring 1)) ; glyph of the following char
678 0 : (fc-id (lglyph-code fc))
679 0 : (gstr (and nil (font-shape-gstring gstring))))
680 0 : (if (and gstr
681 0 : (or (= (lgstring-glyph-len gstr) 1)
682 0 : (and (= (lgstring-glyph-len gstr) 2)
683 0 : (= (lglyph-to (lgstring-glyph gstr 0))
684 0 : (lglyph-to (lgstring-glyph gstr 1))))))
685 : ;; It seems that font-shape-gstring has composed glyphs.
686 0 : gstr
687 : ;; Artificially compose the following glyph with the preceding
688 : ;; dotted-circle.
689 0 : (setq dc (lgstring-glyph gstring 0)
690 0 : fc (lgstring-glyph gstring 1))
691 0 : (let ((dc-width (lglyph-width dc))
692 0 : (fc-width (- (lglyph-rbearing fc) (lglyph-lbearing fc)))
693 0 : (from (lglyph-from dc))
694 0 : (to (lglyph-to fc))
695 : (xoff 0) (yoff 0) (width 0))
696 0 : (if (and (< (lglyph-descent fc) 0)
697 0 : (> (lglyph-ascent dc) (- (lglyph-descent fc))))
698 : ;; Set YOFF so that the following glyph is put on top of
699 : ;; the dotted-circle.
700 0 : (setq yoff (- (- (lglyph-descent fc)) (lglyph-ascent dc))))
701 0 : (if (> (lglyph-width fc) 0)
702 0 : (setq xoff (- (lglyph-rbearing fc))))
703 0 : (if (< dc-width fc-width)
704 : ;; The following glyph is wider, but we don't know how to
705 : ;; align both glyphs. So, try the easiest method;
706 : ;; i.e. align left edges of the glyphs.
707 0 : (setq xoff (- xoff (- dc-width) (- (lglyph-lbearing fc )))
708 0 : width (- fc-width dc-width)))
709 0 : (if (or (/= xoff 0) (/= yoff 0) (/= width 0) (/= (lglyph-width fc) 0))
710 0 : (lglyph-set-adjustment fc xoff yoff width))
711 0 : (lglyph-set-from-to dc from to)
712 0 : (lglyph-set-from-to fc from to))
713 0 : (if (> (lgstring-glyph-len gstring) 2)
714 0 : (lgstring-set-glyph gstring 2 nil))
715 0 : gstring)))
716 :
717 : ;; Allow for bootstrapping without uni-*.el.
718 : (when unicode-category-table
719 : (let ((elt `([,(purecopy "\\c.\\c^+") 1 compose-gstring-for-graphic]
720 : [nil 0 compose-gstring-for-graphic])))
721 : (map-char-table
722 : #'(lambda (key val)
723 : (if (memq val '(Mn Mc Me))
724 : (set-char-table-range composition-function-table key elt)))
725 : unicode-category-table))
726 : ;; for dotted-circle
727 : (aset composition-function-table #x25CC
728 : `([,(purecopy ".\\c^") 0 compose-gstring-for-dotted-circle])))
729 :
730 : (defun compose-gstring-for-terminal (gstring)
731 : "Compose glyph-string GSTRING for terminal display.
732 : Non-spacing characters are composed with the preceding base
733 : character. If the preceding character is not a base character,
734 : each non-spacing character is composed as a spacing character by
735 : prepending a space before it."
736 0 : (let ((nglyphs (lgstring-glyph-len gstring))
737 : (i 0)
738 0 : (coding (lgstring-font gstring))
739 : glyph)
740 0 : (while (and (< i nglyphs)
741 0 : (setq glyph (lgstring-glyph gstring i)))
742 0 : (if (not (char-charset (lglyph-char glyph) coding))
743 0 : (progn
744 : ;; As the terminal doesn't support this glyph, return a
745 : ;; gstring in which each glyph is its own grapheme-cluster
746 : ;; of width 1..
747 0 : (setq i 0)
748 0 : (while (and (< i nglyphs)
749 0 : (setq glyph (lgstring-glyph gstring i)))
750 0 : (if (< (lglyph-width glyph) 1)
751 0 : (lglyph-set-width glyph 1))
752 0 : (lglyph-set-from-to glyph i i)
753 0 : (setq i (1+ i))))
754 0 : (if (= (lglyph-width glyph) 0)
755 0 : (if (eq (get-char-code-property (lglyph-char glyph)
756 0 : 'general-category)
757 0 : 'Cf)
758 0 : (progn
759 : ;; Compose by replacing with a space.
760 0 : (lglyph-set-char glyph 32)
761 0 : (lglyph-set-width glyph 1)
762 0 : (setq i (1+ i)))
763 : ;; Compose by prepending a space.
764 0 : (setq gstring (lgstring-insert-glyph gstring i
765 0 : (lglyph-copy glyph))
766 0 : nglyphs (lgstring-glyph-len gstring))
767 0 : (setq glyph (lgstring-glyph gstring i))
768 0 : (lglyph-set-char glyph 32)
769 0 : (lglyph-set-width glyph 1)
770 0 : (setq i (+ 2)))
771 0 : (let ((from (lglyph-from glyph))
772 0 : (to (lglyph-to glyph))
773 0 : (j (1+ i)))
774 0 : (while (and (< j nglyphs)
775 0 : (setq glyph (lgstring-glyph gstring j))
776 0 : (char-charset (lglyph-char glyph) coding)
777 0 : (= (lglyph-width glyph) 0))
778 0 : (setq to (lglyph-to glyph)
779 0 : j (1+ j)))
780 0 : (while (< i j)
781 0 : (setq glyph (lgstring-glyph gstring i))
782 0 : (lglyph-set-from-to glyph from to)
783 0 : (setq i (1+ i)))))))
784 0 : gstring))
785 :
786 :
787 : (defun auto-compose-chars (func from to font-object string)
788 : "Compose the characters at FROM by FUNC.
789 : FUNC is called with one argument GSTRING which is built for characters
790 : in the region FROM (inclusive) and TO (exclusive).
791 :
792 : If the character are composed on a graphic display, FONT-OBJECT
793 : is a font to use. Otherwise, FONT-OBJECT is nil, and the function
794 : `compose-gstring-for-terminal' is used instead of FUNC.
795 :
796 : If STRING is non-nil, it is a string, and FROM and TO are indices
797 : into the string. In that case, compose characters in the string.
798 :
799 : The value is a gstring containing information for shaping the characters.
800 :
801 : This function is the default value of `auto-composition-function' (which see)."
802 0 : (let ((gstring (composition-get-gstring from to font-object string)))
803 0 : (if (lgstring-shaped-p gstring)
804 0 : gstring
805 0 : (or (fontp font-object 'font-object)
806 0 : (setq func 'compose-gstring-for-terminal))
807 0 : (funcall func gstring))))
808 :
809 : (put 'auto-composition-mode 'permanent-local t)
810 :
811 : (make-variable-buffer-local 'auto-composition-function)
812 : (setq-default auto-composition-function 'auto-compose-chars)
813 :
814 : ;;;###autoload
815 : (define-minor-mode auto-composition-mode
816 : "Toggle Auto Composition mode.
817 : With a prefix argument ARG, enable Auto Composition mode if ARG
818 : is positive, and disable it otherwise. If called from Lisp,
819 : enable the mode if ARG is omitted or nil.
820 :
821 : When Auto Composition mode is enabled, text characters are
822 : automatically composed by functions registered in
823 : `composition-function-table'.
824 :
825 : You can use `global-auto-composition-mode' to turn on
826 : Auto Composition mode in all buffers (this is the default)."
827 : ;; It's defined in C, this stops the d-m-m macro defining it again.
828 : :variable auto-composition-mode)
829 : ;; It's not defined with DEFVAR_PER_BUFFER though.
830 : (make-variable-buffer-local 'auto-composition-mode)
831 :
832 : ;;;###autoload
833 : (define-minor-mode global-auto-composition-mode
834 : "Toggle Auto Composition mode in all buffers.
835 : With a prefix argument ARG, enable it if ARG is positive, and
836 : disable it otherwise. If called from Lisp, enable it if ARG is
837 : omitted or nil.
838 :
839 : For more information on Auto Composition mode, see
840 : `auto-composition-mode' ."
841 : :global t
842 : :variable (default-value 'auto-composition-mode))
843 :
844 : (defalias 'toggle-auto-composition 'auto-composition-mode)
845 :
846 : (provide 'composite)
847 :
848 :
849 :
850 : ;;; composite.el ends here
|