1(define-module text.console.wide-char-setting
2  (use gauche.unicode)
3  (export <wide-char-setting> get-char-width))
4(select-module text.console.wide-char-setting)
5
6;; <wide-char-setting>
7;; Initializable slots:
8;;   mode    - specify the mode for determining widths of wide characters.
9;;             If 'Unicode is specified, character widths are determined
10;;             by East Asian Width of Unicode.
11;;             If 'Surrogate is specified, character widths are determined
12;;             by checking surrogate pairs of Unicode.
13;;             If 'Wide is specified, character widths are determined
14;;             by only character codes.
15;;             Otherwise, wide character support is disabled.
16;;   wide-char-width - a width of wide characters.
17;;   surrogate-char-width - a width of surrogate pair characters of Unicode.
18;;   ambiguous-char-width - a width of ambiguous width characters of Unicode.
19;;             To the above 3 slots, specify a multiple of the width of
20;;             half-width characters.
21;;   emoji-char-workaround - if this is not #f, emoji characters are
22;;             treated as wide characters.
23;;
24(define-class <wide-char-setting> ()
25  ((mode :init-keyword :mode :init-value 'Unicode)
26   (wide-char-width :init-keyword :wide-char-width :init-value 2)
27   (surrogate-char-width :init-keyword :surrogate-char-width :init-value 2)
28   (ambiguous-char-width :init-keyword :ambiguous-char-width :init-value 2)
29   (emoji-char-workaround :init-keyword :emoji-char-workaround :init-value #t)
30   ))
31
32;; Get a character width
33(define (get-char-width wide-char-setting ch)
34  (define wide-char-mode        (~ wide-char-setting'mode))
35  (define wide-char-width       (~ wide-char-setting'wide-char-width))
36  (define surrogate-char-width  (~ wide-char-setting'surrogate-char-width))
37  (define ambiguous-char-width  (~ wide-char-setting'ambiguous-char-width))
38  (define emoji-char-workaround (~ wide-char-setting'emoji-char-workaround))
39  (define chcode (char->integer ch))
40  (cond
41   [(<= 0 chcode #x7f)
42    1]
43   [else
44    (cond-expand
45     [gauche.ces.utf8
46      (case wide-char-mode
47        [(Unicode)
48         (if (and emoji-char-workaround
49                  (<= #x1f000 chcode #x1ffff))
50           wide-char-width
51           (case (char-east-asian-width ch)
52             [(A)      ambiguous-char-width]
53             [(F W)    wide-char-width]
54             [(H N Na) 1]
55             [else     ambiguous-char-width]))]
56        [(Surrogate)
57         (if (>= chcode #x10000)
58           surrogate-char-width
59           wide-char-width)]
60        [(Wide)
61         wide-char-width]
62        [else
63         1])]
64     [else
65      (case wide-char-mode
66        [(Unicode Surrogate Wide)
67         wide-char-width]
68        [else
69         1])])]))
70