1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 combinators.short-circuit combinators.smart fry kernel locals make
5 math math.order math.parser namespaces sequences
6 simple-flat-file splitting strings unicode.data ;
13 TUPLE: weight-levels primary secondary tertiary ignorable? ;
14 : <weight-levels> ( primary secondary tertiary -- weight-levels> )
18 swap >>primary ; inline
20 : parse-weight ( string -- weight )
22 weight-levels new swap rest unclip CHAR: * = swapd >>ignorable?
23 swap "." split first3 [ hex> ] tri@
24 [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
27 : parse-keys ( string -- chars )
28 " " split [ hex> ] "" map-as ;
30 : parse-ducet ( file -- ducet )
31 load-data-file [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
33 "vocab:unicode/UCA/allkeys.txt" parse-ducet ducet set-global
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 ( -- )
47 { 0x0FB2 0x0F71 } ! CE(0FB2) CE(0F71)
62 { 0x0FB3 0x0F71 } ! CE(0FB3) CE(0F71)
78 { 0x0FB2 0x0F71 0x0F72 } ! CE(0FB2) CE(0F71 0F72)
93 { 0x0FB2 0x0F73 } ! CE(0FB2) CE(0F71 0F72)
108 { 0x0FB2 0x0F71 0x0F74 } ! CE(0FB2) CE(0F71 0F74)
123 { 0x0FB2 0x0F75 } ! CE(0FB2) CE(0F71 0F74)
138 { 0x0FB3 0x0F71 0x0F72 } ! CE(0FB3) CE(0F71 0F72)
153 { 0x0FB3 0x0F73 } ! CE(0FB3) CE(0F71 0F72)
168 { 0x0FB3 0x0F71 0x0F74 } ! CE(0FB3) CE(0F71 0F74)
183 { 0x0FB3 0x0F75 } ! CE(0FB3) CE(0F71 0F74)
197 } ducet get-global '[ swap >string _ set-at ] assoc-each ;
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
203 fixup-ducet-for-tibetan
205 : tangut-block? ( char -- ? )
206 ! Tangut Block, Tangut Components Block
208 [ 0x17000 0x187FF between? ]
209 [ 0x18800 0x18AFF between? ]
210 [ 0x18D00 0x18D08 between? ]
213 : nushu-block? ( char -- ? )
214 0x1b170 0x1B2FB between? ; inline
216 : khitan-block? ( char -- ? )
217 0x18b00 0x18cd5 between? ; inline
219 ! https://wiki.computercraft.cc/Module:Unicode_data
220 ! Unicode TR10 - Computing Implicit Weights
221 : base ( char -- base )
223 { [ dup 0x03400 0x04DBF between? ] [ drop 0xFB80 ] } ! Extension A
224 { [ dup 0x20000 0x2A6DD between? ] [ drop 0xFB80 ] } ! Extension B
225 { [ dup 0x2A700 0x2B734 between? ] [ drop 0xFB80 ] } ! Extension C
226 { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
227 { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
228 { [ dup 0x2CEB0 0x2EBE0 between? ] [ drop 0xFB80 ] } ! Extension F
229 { [ dup 0x30000 0x3134A between? ] [ drop 0xFB80 ] } ! Extension G
230 { [ dup 0x03400 0x04DBF between? ] [ drop 0xFB40 ] } ! CJK
231 { [ dup 0x04E00 0x09FFC between? ] [ drop 0xFB40 ] } ! CJK
232 [ drop 0xFBC0 ] ! Other
235 : tangut-AAAA ( char -- weight-levels )
236 drop 0xfb00 0x0020 0x0002 <weight-levels> ; inline
238 : tangut-BBBB ( char -- weight-levels )
239 0x17000 - 0x8000 bitor 0 0 <weight-levels> ; inline
241 : nushu-AAAA ( char -- weight-levels )
242 drop 0xfb01 0x0020 0x0002 <weight-levels> ; inline
244 : nushu-BBBB ( char -- weight-levels )
245 0x1B170 - 0x8000 bitor 0 0 <weight-levels> ; inline
247 : khitan-AAAA ( char -- weight-levels )
248 drop 0xfb02 0x0020 0x0002 <weight-levels> ; inline
250 : khitan-BBBB ( char -- weight-levels )
251 0x18b00 - 0x8000 bitor 0 0 <weight-levels> ; inline
253 : AAAA ( char -- weight-levels )
254 [ base ] [ -15 shift ] bi + 0x0020 0x0002 <weight-levels> ; inline
256 : BBBB ( char -- weight-levels )
257 0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
259 : derive-weight ( 1string -- weight-levels-pair )
262 { [ dup tangut-block? ] [ [ tangut-AAAA ] [ tangut-BBBB ] bi 2array ] }
263 { [ dup nushu-block? ] [ [ nushu-AAAA ] [ nushu-BBBB ] bi 2array ] }
264 { [ dup khitan-block? ] [ [ khitan-AAAA ] [ khitan-BBBB ] bi 2array ] }
265 [ [ AAAA ] [ BBBB ] bi 2array ]
268 : building-last ( -- char )
269 building get [ 0 ] [ last last ] if-empty ;
271 ! https://www.unicode.org/reports/tr10/tr10-41.html#Collation_Graphemes
272 : blocked? ( char -- ? )
273 combining-class dup { 0 f } member?
274 [ drop building-last non-starter? ]
275 [ building-last combining-class = ] if ;
277 : possible-bases ( -- slice-of-building )
278 building get dup [ first non-starter? not ] find-last
279 drop [ 0 ] unless* tail-slice ;
281 :: ?combine ( char slice i -- ? )
282 i slice nth char suffix :> str
283 str ducet get-global key? dup
284 [ str i slice set-nth ] when ;
287 dup blocked? [ 1string , ] [
288 dup possible-bases dup length <iota>
289 [ ?combine ] 2with any?
290 [ drop ] [ 1string , ] if
293 : string>graphemes ( string -- graphemes )
294 [ [ add ] each ] { } make ;
296 : char>weight-levels ( 1string -- weight-levels )
297 ducet get-global ?at [ derive-weight ] unless ; inline
299 : graphemes>weights ( graphemes -- weights )
302 [ 1array ] ! From tailoring
303 [ char>weight-levels ] if
304 ] { } map-as concat ;
306 : append-weights ( weight-levels quot -- seq )
307 [ [ ignorable?>> ] reject ] dip
308 map [ zero? ] reject ; inline
310 : variable-weight ( weight-levels -- obj )
311 dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if ;
313 : weights>bytes ( weights -- array )
316 [ [ primary>> ] append-weights { 0 } ]
317 [ [ secondary>> ] append-weights { 0 } ]
318 [ [ tertiary>> ] append-weights { 0 } ]
319 [ [ [ secondary>> ] [ tertiary>> ] bi [ zero? ] bi@ and not ] filter [ variable-weight ] map ]
321 ] { } append-outputs-as ;
325 : completely-ignorable? ( weight -- ? )
328 [ secondary>> zero? ]
332 : filter-ignorable ( weights -- weights' )
334 [ nip ] [ primary>> zero? and ] 2bi
335 [ swap ignorable?>> or ]
336 [ swap completely-ignorable? or not ] 2bi