LCOV - code coverage report
Current view: top level - lisp - composite.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 398 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 47 0.0 %

          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

Generated by: LCOV version 1.12