]> gitweb.factorcode.org Git - factor.git/blob - basis/unicode/collation/collation.factor
interpolate: split out format into a hook
[factor.git] / basis / unicode / collation / collation.factor
1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 combinators.short-circuit combinators.smart kernel make math
5 math.order math.parser namespaces sequences simple-flat-file
6 splitting strings unicode.data ;
7 IN: unicode.collation
8
9 <PRIVATE
10
11 SYMBOL: ducet
12
13 TUPLE: weight-levels primary secondary tertiary ignorable? ;
14 : <weight-levels> ( primary secondary tertiary -- weight-levels> )
15     weight-levels new
16         swap >>tertiary
17         swap >>secondary
18         swap >>primary ; inline
19
20 : parse-weight ( string -- weight )
21     "]" split but-last [
22         weight-levels new swap rest unclip CHAR: * = swapd >>ignorable?
23         swap "." split first3 [ hex> ] tri@
24         [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
25     ] map ;
26
27 : parse-keys ( string -- chars )
28     split-words [ hex> ] "" map-as ;
29
30 : parse-ducet ( file -- ducet )
31     load-data-file [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
32
33 "vocab:unicode/allkeys.txt" parse-ducet ducet set-global
34
35 ! https://www.unicode.org/reports/tr10/tr10-41.html#Well_Formed_DUCET
36 ! WF5 - Well-formedness 5 condition:
37 ! https://www.unicode.org/reports/tr10/tr10-41.html#WF5
38 !    { "0CC6" "0CC2" "0CD5" } ! 0CD5 is not a non-starter, don't add 2-gram "0CC6" "0CC2"to ducet
39 !    { "0DD9" "0DCF" "0DCA" } ! already in allkeys.txt file
40 !    { "0FB2" "0F71" "0F80" } ! added below
41 !    { "0FB3" "0F71" "0F80" } ! added below
42 ! This breaks the unicode tests that ship in CollationTest_SHIFTED.txt
43 ! but it's supposedly more correct.
44 : fixup-ducet-for-tibetan ( -- )
45     {
46         {
47             { 0x0FB2 0x0F71 } ! CE(0FB2) CE(0F71)
48             {
49                 T{ weight-levels
50                     { primary 12719 }
51                     { secondary 32 }
52                     { tertiary 2 }
53                 }
54                 T{ weight-levels
55                     { primary 12741 }
56                     { secondary 32 }
57                     { tertiary 2 }
58                 }
59             }
60         }
61         {
62             { 0x0FB3 0x0F71 } ! CE(0FB3) CE(0F71)
63             {
64                 T{ weight-levels
65                     { primary 12722 }
66                     { secondary 32 }
67                     { tertiary 2 }
68                 }
69                 T{ weight-levels
70                     { primary 12741 }
71                     { secondary 32 }
72                     { tertiary 2 }
73                 }
74             }
75         }
76
77         {
78             { 0x0FB2 0x0F71 0x0F72 } ! CE(0FB2) CE(0F71 0F72)
79             {
80                 T{ weight-levels
81                     { primary 12719 }
82                     { secondary 32 }
83                     { tertiary 2 }
84                 }
85                 T{ weight-levels
86                     { primary 12743 }
87                     { secondary 32 }
88                     { tertiary 2 }
89                 }
90             }
91         }
92         {
93             { 0x0FB2 0x0F73        } ! CE(0FB2) CE(0F71 0F72)
94             {
95                 T{ weight-levels
96                     { primary 12719 }
97                     { secondary 32 }
98                     { tertiary 2 }
99                 }
100                 T{ weight-levels
101                     { primary 12743 }
102                     { secondary 32 }
103                     { tertiary 2 }
104                 }
105             }
106         }
107         {
108             { 0x0FB2 0x0F71 0x0F74 } ! CE(0FB2) CE(0F71 0F74)
109             {
110                 T{ weight-levels
111                     { primary 12719 }
112                     { secondary 32 }
113                     { tertiary 2 }
114                 }
115                 T{ weight-levels
116                     { primary 12747 }
117                     { secondary 32 }
118                     { tertiary 2 }
119                 }
120             }
121         }
122         {
123             { 0x0FB2 0x0F75        } ! CE(0FB2) CE(0F71 0F74)
124             {
125                 T{ weight-levels
126                     { primary 12719 }
127                     { secondary 32 }
128                     { tertiary 2 }
129                 }
130                 T{ weight-levels
131                     { primary 12747 }
132                     { secondary 32 }
133                     { tertiary 2 }
134                 }
135             }
136         }
137         {
138             { 0x0FB3 0x0F71 0x0F72 } ! CE(0FB3) CE(0F71 0F72)
139             {
140                 T{ weight-levels
141                     { primary 12722 }
142                     { secondary 32 }
143                     { tertiary 2 }
144                 }
145                 T{ weight-levels
146                     { primary 12743 }
147                     { secondary 32 }
148                     { tertiary 2 }
149                 }
150             }
151         }
152         {
153             { 0x0FB3 0x0F73        } ! CE(0FB3) CE(0F71 0F72)
154             {
155                 T{ weight-levels
156                     { primary 12722 }
157                     { secondary 32 }
158                     { tertiary 2 }
159                 }
160                 T{ weight-levels
161                     { primary 12743 }
162                     { secondary 32 }
163                     { tertiary 2 }
164                 }
165             }
166         }
167         {
168             { 0x0FB3 0x0F71 0x0F74 } ! CE(0FB3) CE(0F71 0F74)
169             {
170                 T{ weight-levels
171                     { primary 12722 }
172                     { secondary 32 }
173                     { tertiary 2 }
174                 }
175                 T{ weight-levels
176                     { primary 12747 }
177                     { secondary 32 }
178                     { tertiary 2 }
179                 }
180             }
181         }
182         {
183             { 0x0FB3 0x0F75        } ! CE(0FB3) CE(0F71 0F74)
184             {
185                 T{ weight-levels
186                     { primary 12722 }
187                     { secondary 32 }
188                     { tertiary 2 }
189                 }
190                 T{ weight-levels
191                     { primary 12747 }
192                     { secondary 32 }
193                     { tertiary 2 }
194                 }
195             }
196         }
197     } ducet get-global '[ swap >string _ set-at ] assoc-each ;
198
199 ! These values actually break the collation unit tests in CollationTest_SHIFTED.txt
200 ! So we disable those tests in favor of supposedly better collation for Tibetan.
201 ! https://www.unicode.org/reports/tr10/tr10-41.html#Well_Formed_DUCET
202
203 fixup-ducet-for-tibetan
204
205 : tangut-block? ( char -- ? )
206     {
207         [ 0x17000 0x18AFF between? ] ! Tangut and Tangut Components
208         [ 0x18D00 0x18D8F between? ] ! Tangut Supplement
209     } 1|| ; inline
210
211 : nushu-block? ( char -- ? )
212     0x1B170 0x1B2FF between? ; inline
213
214 : khitan-block? ( char -- ? )
215     0x18B00 0x18CFF between? ; inline
216
217 ! https://wiki.computercraft.cc/Module:Unicode_data
218 ! Unicode TR10 - Computing Implicit Weights
219 : base ( char -- base )
220     {
221         { [ dup 0x03400 0x04DBF between? ] [ drop 0xFB80 ] } ! Extension A
222         { [ dup 0x20000 0x2A6DF between? ] [ drop 0xFB80 ] } ! Extension B
223         { [ dup 0x2A700 0x2B739 between? ] [ drop 0xFB80 ] } ! Extension C
224         { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
225         { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
226         { [ dup 0x2CEB0 0x2EBE0 between? ] [ drop 0xFB80 ] } ! Extension F
227         { [ dup 0x30000 0x3134A between? ] [ drop 0xFB80 ] } ! Extension G
228         { [ dup 0x31350 0x323AF between? ] [ drop 0xFB80 ] } ! Extension H
229         { [ dup 0x2EBF0 0x2EE5D between? ] [ drop 0xFB80 ] } ! Extension I
230         { [ dup 0x2F800 0x2FA1D between? ] [ drop 0xFB80 ] } ! CJK Compatibility
231         { [ dup 0x04E00 0x09FFF between? ] [ drop 0xFB40 ] } ! CJK
232         { [ dup 0x0F900 0x0FAD9 between? ] [ drop 0xFB40 ] } ! CJK
233         [ drop 0xFBC0 ] ! Other
234     } cond ;
235
236 : tangut-AAAA ( char -- weight-levels )
237     drop 0xfb00 0x0020 0x0002 <weight-levels> ; inline
238
239 : tangut-BBBB ( char -- weight-levels )
240     0x17000 - 0x8000 bitor 0 0 <weight-levels> ; inline
241
242 : nushu-AAAA ( char -- weight-levels )
243     drop 0xfb01 0x0020 0x0002 <weight-levels> ; inline
244
245 : nushu-BBBB ( char -- weight-levels )
246     0x1B170 - 0x8000 bitor 0 0 <weight-levels> ; inline
247
248 : khitan-AAAA ( char -- weight-levels )
249     drop 0xfb02 0x0020 0x0002 <weight-levels> ; inline
250
251 : khitan-BBBB ( char -- weight-levels )
252     0x18b00 - 0x8000 bitor 0 0 <weight-levels> ; inline
253
254 : AAAA ( char -- weight-levels )
255     [ base ] [ -15 shift ] bi + 0x0020 0x0002 <weight-levels> ; inline
256
257 : BBBB ( char -- weight-levels )
258     0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
259
260 : derive-weight ( 1string -- weight-levels-pair )
261     first
262     {
263         { [ dup tangut-block? ] [ [ tangut-AAAA ] [ tangut-BBBB ] bi 2array ] }
264         { [ dup nushu-block? ] [ [ nushu-AAAA ] [ nushu-BBBB ] bi 2array ] }
265         { [ dup khitan-block? ] [ [ khitan-AAAA ] [ khitan-BBBB ] bi 2array ] }
266         [ [ AAAA ] [ BBBB ] bi 2array ]
267     } cond ;
268
269 : building-last ( -- char )
270     building get [ 0 ] [ last last ] if-empty ;
271
272 ! https://www.unicode.org/reports/tr10/tr10-41.html#Collation_Graphemes
273 : blocked? ( char -- ? )
274     combining-class dup { 0 f } member?
275     [ drop building-last non-starter? ]
276     [ building-last combining-class = ] if ;
277
278 : possible-bases ( -- slice-of-building )
279     building get dup [ first non-starter? not ] find-last
280     drop [ 0 ] unless* tail-slice ;
281
282 :: ?combine ( char slice i -- ? )
283     i slice nth char suffix :> str
284     str ducet get-global key? dup
285     [ str i slice set-nth ] when ;
286
287 : add ( char -- )
288     dup blocked? [ 1string , ] [
289         dup possible-bases dup length <iota>
290         [ ?combine ] 2with any?
291         [ drop ] [ 1string , ] if
292     ] if ;
293
294 : string>graphemes ( string -- graphemes )
295     [ [ add ] each ] { } make ;
296
297 : char>weight-levels ( 1string -- weight-levels )
298     ducet get-global ?at [ derive-weight ] unless ; inline
299
300 : graphemes>weights ( graphemes -- weights )
301     [
302         dup weight-levels?
303         [ 1array ] ! From tailoring
304         [ char>weight-levels ] if
305     ] { } map-as concat ;
306
307 : append-weights ( weight-levels quot -- seq )
308     [ [ ignorable?>> ] reject ] dip
309     map [ zero? ] reject ; inline
310
311 : variable-weight ( weight-levels -- obj )
312     dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if ;
313
314 : weights>bytes ( weights -- array )
315     [
316         {
317             [ [ primary>> ] append-weights { 0 } ]
318             [ [ secondary>> ] append-weights { 0 } ]
319             [ [ tertiary>> ] append-weights { 0 } ]
320             [ [ [ secondary>> ] [ tertiary>> ] bi [ zero? ] both? ] reject [ variable-weight ] map ]
321         } cleave
322     ] { } append-outputs-as ;
323
324 PRIVATE>
325
326 : completely-ignorable? ( weight -- ? )
327     {
328         [ primary>> zero? ]
329         [ secondary>> zero? ]
330         [ tertiary>> zero? ]
331     } 1&& ;
332
333 : filter-ignorable ( weights -- weights' )
334     f swap [
335         [ nip ] [ primary>> zero? and ] 2bi
336         [ swap ignorable?>> or ]
337         [ swap completely-ignorable? or not ] 2bi
338     ] filter nip ;